www.gusucode.com > 地方成人教育中心整站源代码 1 > 地方成人教育中心整站源代码 1.0/bbs/inc/Dv_ClsMain.asp
<object runat="server" id="DvStream" progid="ADODB.Stream"></object> <% '========================================================= ' File: Dv_ClsMain.asp ' Version:8.3.0 ' Date: 20010-2-10 ' Script Written by dvbbs.net '========================================================= ' Copyright (C) 2003,2004 AspSky.Net. All rights reserved. ' Web: http://www.aspsky.net,http://www.dvbbs.net ' Email: eway@aspsky.net '========================================================= '是否商业版,非官方SQL版本请在此设置为0以及在Conn中设置论坛为SQL数据库,否则显示不正常 Const IsBuss=1 Const Dvbbs_Server_Url = "http://server.dvbbs.net/" Const Dvbbs_PayTo_Url = "http://pay.dvbbs.net/" Const fversion="8.3.0" Dim IP_MAX Const guestxml="<?xml version=""1.0"" encoding=""gb2312""?><xml><userinfo statuserid=""0"" userid=""0"" username=""客人"" userclass=""客人"" usergroupid=""7"" cometime="""" boardid=""0"" activetime="""" statusstr=""""/></xml>" Class Cls_Forum Rem Const Public BoardID,SqlQueryNum,Forum_Info,Forum_Setting,Forum_user,Forum_Copyright,Forum_ads,Forum_ChanSetting,Forum_UploadSetting Public Forum_sn,Forum_Version,Stats,StyleName,ErrCodes,NowUseBBS,Cookiepath,ScriptFolder,BoardInfoData,UserSession Public MainSetting,sysmenu,UserToday,BoardJumpList,BoardList,CacheData,Maxonline Public VipGroupUser,Vipuser,Boardmaster,Superboardmaster,Master,FoundIsChallenge,FoundUser Public ScriptName,MemberName,MemberWord,MemberClass,UserHidden,UserID,UserTrueIP,UserPermission Public sendmsgnum,sendmsgid,sendmsguser,Page_Admin Public BadWords,rBadWord,Forum_emot,Forum_PostFace,Forum_UserFace,SkinID,Forum_PicUrl Private Forum_CSS,Main_Sid,Nowstats,CssID Public Reloadtime,CacheName,UserGroupID,Lastlogin,GroupSetting,FoundUserPer,UserGroupParent,UserGroupParentID,LastMsg Private LocalCacheName,IsTopTable,ShowErrType Public Board_Setting,LastPost,Board_user,BoardType,Board_Data,Sid,Boardreadme,BoardRootID,BoardParentID Private Is_Isapi_Rewrite,iArchiverUrl Public ModHtmlLinked,ArchiverUrl,ArchiverType Public Browser,version ,platform,IsSearch,Cls_IsSearch Public IsUserPermissionOnly,IsUserPermissionAll,ShowSQL,actforip,DvRegExp,DvRegExp1 Public GroupName,ScriptPath,Forum_apis,TyClsGroup,TyReadOnly,TyClsGroupM 'fish Rem Const Function iCreateObject(str) 'iis5创建对象方法Server.CreateObject(ObjectName); 'iis6创建对象方法CreateObject(ObjectName); '默认为iis6,如果在iis5中使用,需要改为Server.CreateObject(str); Set iCreateObject=CreateObject(str) End Function Function CreateXmlDoc(str) Set CreateXmlDoc = iCreateObject(str) CreateXmlDoc.async=false End Function Public Function ReadTextFile(fileName) On Error Resume Next 'Response.Write Server.MapPath(ScriptPath&fileName) DvStream.charset="gb2312" DvStream.Mode = 3 DvStream.open() DvStream.LoadFromFile(Server.MapPath(ScriptPath&fileName)) ReadTextFile=DvStream.ReadText DvStream.close() If Err Then err.Clear PageEnd() Response.Clear Response.Write ScriptPath&fileName & "文件不存在!请检查,或者恢复官方模板数据!" Response.End End If End Function Function writeToFile(fileName,Text) DvStream.charset="gb2312" DvStream.Mode = 3 DvStream.open() DvStream.WriteText(Text) DvStream.SaveToFile Server.MapPath(ScriptPath&fileName),2 DvStream.close() End Function Private Sub Class_Initialize() End Sub public Sub PageInit() ScriptPath="./" Forum_sn="DvForum 8.3"'如果一个虚拟目录或站点开多个论坛,则每个要错开,不能定义同一个名称 Forum_sn=Forum_sn & "_" & Request.servervariables("SERVER_NAME") CacheName="DvCache 8.3"'如果一个虚拟目录或站点开多个论坛,则每个要错开,不能定义同一个名称 IsUserPermissionOnly = 0 IsUserPermissionAll = 0 ShowErrType = 0 '错误信息显示模式 SqlQueryNum = 0 Reloadtime=600 IsTopTable = 0 VipGroupUser = False:IsSearch=False:Cls_IsSearch=False Vipuser = False:Boardmaster = False Superboardmaster = False:Master = False:FoundIsChallenge = False:FoundUser = False BoardID = Request("BoardID") If IsNumeric(BoardID) = 0 or BoardID = "" Then BoardID = 0 BoardID = Clng(BoardID) MemberName = checkStr(Trim(Request.Cookies(Forum_sn)("username"))) MemberWord = checkStr(Trim(Request.Cookies(Forum_sn)("password"))) UserHidden = Trim(Request.Cookies(Forum_sn)("userhidden")) UserID = Trim(Request.Cookies(Forum_sn)("UserID")) If IsNumeric(UserHidden) = 0 or Userhidden = "" Then UserHidden = 2 If IsNumeric(UserID) = 0 Or UserID="" Then UserID=0 UserID = Clng(UserID) UserTrueIP = getIP() IP_MAX=0 Dim Tmpstr Tmpstr = Request.ServerVariables("PATH_INFO") Tmpstr = Split(Tmpstr,"/") ScriptName = Lcase(Tmpstr(UBound(Tmpstr))) ScriptFolder = Lcase(Tmpstr(UBound(Tmpstr)-1)) & "/" MemberClass = checkStr(Request.Cookies(Forum_sn)("userclass")) Page_Admin=False If InStr(ScriptName,"showerr")>0 Or InStr(ScriptName,"login")>0 Or InStr(ScriptName,"admin_")>0 Or InStr(ScriptName,"ajax")>0 Then Page_Admin=True sendmsgnum=0:sendmsgid=0:sendmsguser="" '模拟HTML部分开始 Is_Isapi_Rewrite = 0 If Is_Isapi_Rewrite = 0 Then ModHtmlLinked = "?" ArchiverType = 0 If InStr(ScriptName,"indexhtml.asp") > 0 Then iArchiverUrl = Lcase(Request.ServerVariables("QUERY_STRING")) If iArchiverUrl <> "" Then ArchiverUrl = iArchiverUrl iArchiverUrl = Split(iArchiverUrl,"_") If iArchiverUrl(0) = "list" And Ubound(iArchiverUrl) = 5 Then If IsNumeric(iArchiverUrl(1)) Then ArchiverType = 1 BoardID = Clng(iArchiverUrl(1)) End If End If End If End If End Sub 'isapi_write Public Function ArchiveHtml(Textstr) Str=Textstr If isUrlreWrite = 1 Then Dim Str,re,Matches,Match Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)(&|&)topicmode=(\d+)?(&|&)list_type=([\d,]+)?(&|&)page=(\d+)?" str = re.Replace(str,"<a$1index_$2_$4_$6_$8.html") re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)(&|&)action=(.[^&]*)?(&|&)topicmode=(\d+)?(&|&)list_type=([\d,]+)?(&|&)page=(\d+)?" str = re.Replace(str,"<a$1index_$2_$4_$6_$8_$10.html") re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)(&|&)page=(\d+)?(&|&)action=(.[^<>""\'\s]*)?" str = re.Replace(str,"<a$1index_$2_$4_$6.html") re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)(&|&)topicmode=(\d+)?" str = re.Replace(str,"<a$1index_$2_$4.html") re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)(&|&)page=(\d+)?" str = re.Replace(str,"<a$1index_$2_$4_.html") re.Pattern = "<a(.[^>]*)index\.asp\?boardid=(\d+)" str = re.Replace(str,"<a$1index_$2.html") re.Pattern = "<a(.[^>|_]*)index\.asp" str = re.Replace(str,"<a$1index.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)replyid=(\d+)?(&|&)id=(\d+)?(&|&)skin=(\d+)?(&|&)page=(\d+)?(&|&)star=(\d+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6_skin$8_$10_$12.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)replyid=(\d+)?(&|&)id=(\d+)?(&|&)skin=(\d+)?(&|&)star=(\d+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6_skin$8_$10.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)replyid=(\d+)?(&|&)id=(\d+)?(&|&)skin=(\d+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6_skin$8.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)id=(\d+)?(&|&)authorid=(\d+)?(&|&)page=(\d+)?(&|&)(star|move)=([\w\d]+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6_$8_$11.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)id=(\d+)?(&|&)page=(\d+)?(&|&)(star|move)=([\w\d]+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6_$9.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)id=(\d+)?(&|&)page=(\d+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4_$6.html") re.Pattern = "<a(.[^>]*)dispbbs\.asp\?boardid=(\d+)(&|&)id=(\d+)?" str = re.Replace(str,"<a$1dispbbs_$2_$4.html") re.Pattern = "<a(.[^>]*)dv_rss\.asp\?s=(.[^<|>|""|\'|\s]*)" str = re.Replace(str,"<a$1dv_rss_$2.html") re.Pattern = "<a(.[^>]*)dv_rss\.asp" str = re.Replace(str,"<a$1dv_rss.html") Set Re=Nothing End If ArchiveHtml = Str End Function Private Function getIP() Dim strIPAddr If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then strIPAddr = Request.ServerVariables("REMOTE_ADDR") ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1) actforip=Request.ServerVariables("REMOTE_ADDR") ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1) actforip=Request.ServerVariables("REMOTE_ADDR") Else strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") actforip=Request.ServerVariables("REMOTE_ADDR") End If getIP = CheckStr(Trim(Mid(strIPAddr, 1, 30))) End Function Private Sub class_terminate() End Sub Public Sub PageEnd() If EnabledSession Then If Not UserSession Is Nothing Then Session(CacheName & "UserID")= UserSession.xml End If Set UserSession=Nothing If IsObject(Conn) Then Conn.Close : Set Conn = Nothing If IsObject(Plus_Conn) Then Plus_Conn.Close : Set Plus_Conn = Nothing Set DvRegExp= Nothing Set DvRegExp1= Nothing CacheData=Null Forum_Setting = Null Forum_UploadSetting = Null Forum_user =Null Forum_ChanSetting =Null BadWords = Null rBadWord = Null Forum_ads=Null End Sub Public Sub Sendmessanger(touserid,senduser,messangertext) Dim Node If Not IsObject( Application(Dvbbs.CacheName&"_messanger")) Then Set Application(Dvbbs.CacheName&"_messanger")=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) Application(Dvbbs.CacheName&"_messanger").appendChild( Application(Dvbbs.CacheName&"_messanger").createElement("xml")) End If For Each Node in Application(Dvbbs.CacheName&"_messanger").documentElement.SelectNodes("messanger") If datediff("s",Node.selectSingleNode("@sendtime").text,Now()) > 72000 Then Application(Dvbbs.CacheName&"_messanger").documentElement.removeChild(Node) End If Next Set Node=Application(Dvbbs.CacheName&"_messanger").documentElement.appendChild(Application(Dvbbs.CacheName&"_messanger").createNode(1,"messanger","")) Node.attributes.setNamedItem(Application(Dvbbs.CacheName&"_messanger").createNode(2,"sendtime","")).text=Now() Node.attributes.setNamedItem(Application(Dvbbs.CacheName&"_messanger").createNode(2,"touserid","")).text=touserid Node.attributes.setNamedItem(Application(Dvbbs.CacheName&"_messanger").createNode(2,"senduser","")).text=senduser Node.text=messangertext End Sub Public Property Let Name(ByVal vNewValue) LocalCacheName = LCase(vNewValue) End Property Public Property Let Value(ByVal vNewValue) If LocalCacheName<>"" Then Application.Lock Application(CacheName & "_" & LocalCacheName &"_-time")=Now() Application(CacheName & "_" & LocalCacheName) = vNewValue Application.unLock End If End Property Public Property Get Value() If LocalCacheName<>"" Then Value=Application(CacheName & "_" & LocalCacheName) End If End Property Public Function ObjIsEmpty() 'Response.Write DateDiff("s",CDate(Application(CacheName & "_" & LocalCacheName &"_-time")),Now())&"秒" ObjIsEmpty=False If IsDate(Application(CacheName & "_" & LocalCacheName &"_-time")) Then If DateDiff("s",CDate(Application(CacheName & "_" & LocalCacheName &"_-time")),Now()) > (60*Reloadtime) Then ObjIsEmpty=True Else ObjIsEmpty=True End If If ObjIsEmpty Then RemoveCache() End Function Public Sub RemoveCache() Application.Lock Application.Contents.Remove(CacheName & "_" & LocalCacheName) Application.Contents.Remove(CacheName & "_" & LocalCacheName &"_-time") Application.unLock End Sub '取得基本设置数据 Public Sub loadSetup() Dim Rs,locklist,ip,ip1,XMLDom,Node,i Name="setup" Set Rs = Dvbbs.Execute("Select id, Forum_Setting, Forum_ads, Forum_Badwords, Forum_rBadword, Forum_Maxonline, Forum_MaxonlineDate, Forum_TopicNum, Forum_PostNum, Forum_TodayNum, Forum_UserNum, Forum_YesTerdayNum, Forum_MaxPostNum, Forum_MaxPostDate, Forum_lastUser, Forum_LastPost, Forum_BirthUser, Forum_Sid, Forum_Version, Forum_NowUseBBS, Forum_IsInstall, Forum_challengePassWord, Forum_Ad, Forum_ChanName, Forum_ChanSetting, Forum_LockIP, Forum_Cookiespath, Forum_Boards, Forum_alltopnum, Forum_pack, Forum_Cid, Forum_AvaSiteID, Forum_AvaSign, Forum_AdminFolder, Forum_BoardXML, Forum_Css, Forum_apis From [Dv_Setup]") Value = Rs.GetRows(1) CacheData=value Set XMLDom=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) XMLDom.appendChild(XMLDom.createElement("xml")) locklist=Trim(CacheData(25,0)) locklist=Split(locklist,"|") For Each Ip in locklist Ip1=Split(Ip,".") Set Node=XMLDom.documentElement.appendChild(XMLDom.createNode(1,"lockip","")) For i=0 to UBound(ip1) Node.attributes.setNamedItem(XMLDom.createNode(2,"number"& (i+1),"")).text=ip1(i) Next Next Application.Lock Set Application(CacheName & "_forum_lockip")=XMLDom Application.UnLock Set XMLDom=Nothing If Not isobject(Application(CacheName & "_getbrowser")) Then Dim stylesheet Set stylesheet=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) stylesheet.load Server.MapPath(MyDbPath &"inc\GetBrowser.xslt") Application.Lock Set Application(CacheName & "_getbrowser")=Dvbbs.iCreateObject("msxml2.XSLTemplate" & MsxmlVersion) Application(CacheName & "_getbrowser").stylesheet=stylesheet Application.unLock End If Application.Lock Set Application(CacheName & "_accesstopic")=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) Application(CacheName & "_accesstopic").Loadxml Replace(Replace(CacheData(34,0),Chr(10),""),Chr(13),"") Application.unLock End Sub Public Sub LoadBbsBoard() End Sub Public Sub LoadBoardList() Dim TempXmlDoc,TempMasterDoc,ChildNode Dim Rs,boardmaster,master,node,Board_setting Set Rs=Execute("select boardid,boardtype,ParentID,depth,rootid,Child,indeximg,parentstr,cid as checkout,cid as hidden,cid as nopost,cid as checklock,cid as mode,cid as simplenesscount,readme,boardmaster From Dv_board Order by rootid,Orders") Set TempXmlDoc = RecordsetToxml(rs,"board","BoardList") Rs.Close Set TempMasterDoc = Dvbbs.CreateXmlDoc("Msxml2.FreeThreadedDOMDocument"& MsxmlVersion) TempMasterDoc.documentElement = TempMasterDoc.createElement("masterlist") Set Rs=Execute("select boardmaster,boardid,Board_setting From Dv_board Order by Orders") Do While Not Rs.EOF Set Node = TempMasterDoc.documentElement.appendChild(TempMasterDoc.createNode(1,"boardmaster","")) Node.setAttribute "boardid",Rs(1) boardmaster=split(Rs("boardmaster")&"","|") For Each Master In boardmaster Node.appendChild(TempMasterDoc.createNode(1,"master","")).text=Master Next Board_setting=Split(Rs("Board_setting"),",") TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@checkout").text=Board_setting(2) TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@hidden").text=Board_setting(1) TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@nopost").text=Board_setting(43) TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@checklock").text=Board_setting(0) TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@mode").text=Board_setting(39) TempXmlDoc.documentElement.selectSingleNode("board[@boardid='"& Rs("Boardid")&"']/@simplenesscount").text=Board_setting(41) Rs.MoveNext Loop Rs.Close Set Rs= Nothing Application.Lock Set Application(CacheName&"_boardmaster") = TempMasterDoc Set Application(CacheName&"_boardlist") = TempXmlDoc Application(CacheName&"_boardmaster_xml") = TempMasterDoc.xml Application(CacheName&"_boardlist_xml") = TempXmlDoc.xml Application.unLock End Sub Public Sub LoadPlusMenu() Name = "ForumPlusMenu" Dim Rs,XMLDom,Node,plus_setting,stylesheet,XMLStyle,proc Set Rs=Execute("Select id,plus_type,plus_name,mainpage,plus_copyright,plus_setting,isshowmenu as width,isshowmenu as height From Dv_Plus Where Isuse=1 Order By ID") Set XMLDom=RecordsetToxml(rs,"plus","") Rs.close() Set Rs=Nothing For Each Node In XMLDom.documentElement.selectNodes("plus") plus_setting=Split(Split(node.selectSingleNode("@plus_setting").text,"|||")(0),"|") node.selectSingleNode("@plus_setting").text=plus_setting(0) node.selectSingleNode("@width").text=plus_setting(1) node.selectSingleNode("@height").text=plus_setting(2) Next Set XMLStyle=Dvbbs.iCreateObject("msxml2.XSLTemplate" & MsxmlVersion) Set stylesheet=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) stylesheet.load Server.MapPath(MyDbPath &"inc\Templates\plusmenu.xslt") XMLStyle.stylesheet=stylesheet Set proc=XMLStyle.createProcessor() proc.input = XMLDom proc.transform() value=proc.output End Sub Public Sub LoadBoardData(bid) Dim Rs Application.Lock Set Rs=Execute("select boardid,boarduser,board_ads,board_user,isgroupsetting,rootid,board_setting,sid,cid,Rules From Dv_board Where Boardid="&bid) Set Application(CacheName &"_boarddata_" & bid)=RecordsetToxml(rs,"boarddata","") Rs.Close Set Rs= Nothing Application.unLock End Sub Public Sub LoadBoardinformation(bid)'加载动态板面信息数据 Dim Rs,lastpost,i Application.Lock Set Rs=Execute("select boardid,boardtopstr,postnum,topicnum,todaynum,lastpost as lastpost_0 From Dv_board Where Boardid="&bid) Set Application(CacheName &"_information_" & bid)=RecordsetToxml(rs,"information","") lastpost=Split(Application(CacheName &"_information_" & bid).documentElement.selectSingleNode("information/@lastpost_0").text,"$") For i=0 to UBound(lastpost) Application(CacheName &"_information_" & bid).documentElement.firstChild.setAttribute "lastpost_"& i,lastpost(i) If i = 7 Then Exit For Next Rs.Close Set Rs= Nothing Application.unLock End Sub Public Sub LoadAllBoardinformation()'加载所有板面信息数据 Dim Rs,lastpost,i Dim TempXmlDom,Node,TempNode,TempXmlDom1 Set Rs=Execute("select boardid,boardtopstr,postnum,topicnum,todaynum,lastpost as lastpost_0 From Dv_board Order by Orders") Set TempXmlDom = RecordsetToxml(rs,"information","") Rs.Close Set Rs = Nothing For Each Node In TempXmlDom.documentElement.selectNodes("information") lastpost=Split(Node.getAttribute("lastpost_0"),"$") For i=0 to UBound(lastpost) Node.setAttribute "lastpost_"& i,lastpost(i) If i = 7 Then Exit For Next Set TempXmlDom1=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) Set TempNode = TempXmlDom1.appendChild(TempXmlDom1.createNode(1,"xml","")) TempNode.appendChild(Node) Application.Lock Set Application(CacheName &"_information_" & Node.getAttribute("boardid")) = TempXmlDom1 Application.UnLock Next If IsObject(TempXmlDom1) Then Set TempXmlDom1 = Nothing End Sub Public Sub LoadGroupSetting() Dim Rs Set Rs=Dvbbs.Execute("Select GroupSetting,UserGroupID,ParentGID,IsSetting,UserTitle,TyClsGroup,TyClsGroupM From Dv_UserGroups") 'fish,新增用户组开关 Set Application(CacheName &"_groupsetting")=RecordsetToxml(rs,"usergroup","") Set Rs=Dvbbs.Execute("Select UserGroupID,usertitle,titlepic,orders From Dv_UserGroups order by orders") Set Application(CacheName &"_grouppic")=RecordsetToxml(rs,"usergroup","grouppic") Rs.close() Set Rs=Nothing End Sub Public Sub Loadstyle() Dim Rs Application.Lock Set Rs=Dvbbs.Execute("Select * From Dv_Templates") Set Application(CacheName &"_style")=RecordsetToxml(rs,"style","") Rs.close() Set Rs=Nothing Application.UnLock LoadStyleMenu() End Sub Public Sub LoadStyleMenu()'生成风格选单数据 Name="style_list" Dim HTMLstr HTMLStr="<a href=""cookies.asp?action=stylemod&boardid=$boardid"" >恢复默认设置</a>" Dim Node For Each Node in Application(CacheName &"_style").documentElement.selectNodes("style") HTMLstr=(HTMLstr&"<br /><a href=""cookies.asp?action=stylemod&skinid="& node.selectSingleNode("@id").text & "&boardid=$boardid"">"& node.selectSingleNode("@type").text& "</a>") Next value=HTMLstr End Sub Public Sub UpdateForum_Info(act)'act=0 不处理缓存,act=1 处理缓存 If value <> "1900-1-1" Then value="1900-1-1" Dim Rs,LastPostInfo,TempStr,i,Board Dim Forum_YesterdayNum,Forum_TodayNum,Forum_LastPost,Forum_MaxPostNum,Forum_MaxPostDate Set Rs=Execute("Select Top 1 Forum_YesterdayNum,Forum_TodayNum,Forum_LastPost,Forum_MaxPostNum From Dv_Setup") Forum_YesterdayNum=Rs(0) Forum_TodayNum=Rs(1) Forum_LastPost=Rs(2) Forum_MaxPostNum=Rs(3) Rs.close() Set Rs=Nothing LastPostInfo = Split(Forum_LastPost,"$") If Not IsDate(LastPostInfo(2)) Then LastPostInfo(2)=Now() If DateDiff("d",CDate(LastPostInfo(2)),Now())<>0 Then'最后发帖时间不是今天, TempStr=LastPostInfo(0)&"$"&LastPostInfo(1)&"$"&Now()&"$"&LastPostInfo(3)&"$"&LastPostInfo(4)&"$"&LastPostInfo(5)&"$"&LastPostInfo(6)&"$"&LastPostInfo(7) Execute("Update Dv_Setup Set Forum_YesterdayNum="&Forum_TodayNum&",Forum_LastPost='"&TempStr&"',Forum_TodayNum=0") Execute("update Dv_board Set TodayNum=0") If act=1 Then If not IsObject(Application(CacheName&"_boardlist")) Then LoadBoardList() For Each board in Application(CacheName&"_boardlist").documentElement.selectNodes("board/@boardid") LoadBoardinformation board.text Next End If End If If Forum_TodayNum >Forum_MaxPostNum Then Execute("Update Dv_Setup Set Forum_MaxPostNum="&Forum_TodayNum&",Forum_MaxPostDate="&SqlNowString) End If If act=1 Then loadSetup() Dim xmlhttp If IsSqlDataBase =0 Then On Error Resume Next Set xmlhttp = Dvbbs.CreateXmlDoc("msxml2.ServerXMLHTTP") xmlhttp.setTimeouts 65000, 65000, 65000, 65000 xmlhttp.Open "POST",Get_ScriptNameUrl& "Loadservoces.asp",false xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlhttp.send() Set xmlhttp = Nothing End If End If Name="Date" value=Date() End Sub Public Sub GetForum_Setting() Name="Date" If ObjIsEmpty() Then UpdateForum_Info(0) ElseIf Cstr(value) <> Cstr(Date()) Then UpdateForum_Info(1) End If Name="setup" If ObjIsEmpty Then loadSetup() If Not IsObject(Application(CacheName&"_boardlist")) Then LoadBoardList() End If If Not IsObject(Application(CacheName &"_style")) Then Loadstyle() End If Name="setup" CacheData=value Forum_apis=CacheData(36,0) Dim Setting,OpenTime,ischeck:Setting= Split(CacheData(1,0),"|||"):Forum_Info = Split (Setting(0),",") Forum_Setting = Split (Setting(1),","):Forum_UploadSetting = Split(Forum_Setting(7),"|") Forum_user = Setting(2):Forum_user = Split (Forum_user,","):Forum_Copyright = Setting(3) Forum_ChanSetting = Split(CacheData(24,0),",") Forum_Version = fversion 'CacheData(18,0) BadWords = Split(CacheData(3,0),"|") Set DvRegExp=new RegExp DvRegExp.IgnoreCase =True DvRegExp.Global=true Set DvRegExp1=new RegExp DvRegExp1.IgnoreCase =True DvRegExp1.Global=false if(CacheData(3,0)<>"") Then DvRegExp.Pattern="(" & CacheData(3,0) &")" DvRegExp1.Pattern="(" & CacheData(3,0) &")" End if rBadWord = Split(CacheData(4,0),"|"): Main_Sid=CacheData(17,0):Maxonline = CacheData(5,0):NowUseBBS = CacheData(19,0):Cookiepath = CacheData(26,0) If ScriptFolder = Lcase(CacheData(33,0)) Then Page_Admin = True Rem 禁止代理服务器访问开始,如需要允许访问,请屏蔽此段代码。 If Forum_Setting(100)="1" Then If actforip <> "" Then Session(CacheName & "UserID")=empty Set Dvbbs=Nothing Response.Status = "302 Object Moved" Response.End End If If UBound(Forum_Setting)> 101 Then IP_MAX=CLng(Forum_Setting(101)) Else IP_MAX=0 End If End If Rem 禁止代理服务器访问结束 Rem Hantg 2007-12-05 If UBound(Forum_Setting)<107 Then Redim Preserve Forum_Setting(106) End If If Forum_Setting(21)="1" And Not Page_Admin Then Set Dvbbs=Nothing:Response.redirect "showerr.asp?action=stop" If BoardID <>0 Then If Application(CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&BoardID&"']") Is Nothing Then Set Dvbbs=Nothing Response.Write "错误的版面参数" Response.End End If End If If BoardID > 0 Then If Not IsObject(Application(CacheName &"_boarddata_" & Boardid)) Then LoadBoardData boardid If Not IsObject (Application(CacheName &"_information_" & boardid)) Then LoadBoardinformation BoardID Dim Nodelist,node Forum_ads = Split(Application(CacheName &"_boarddata_" & Boardid).documentElement.selectSingleNode("boarddata/@board_ads").text,"$") Forum_user = Split(Application(CacheName &"_boarddata_" & Boardid).documentElement.selectSingleNode("boarddata/@board_user").text,",") board_Setting = Split(Application(CacheName &"_boarddata_" & Boardid).documentElement.selectSingleNode("boarddata/@board_setting").text,",") BoardType = Application(CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&BoardID&"']/@boardtype").text BoardRootID = Application(CacheName &"_boarddata_" & Boardid).documentElement.selectSingleNode("boarddata/@rootid").text BoardParentID=CLng(Application(CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&BoardID&"']/@parentid").text) Sid = Application(CacheName &"_boarddata_" & Boardid).documentElement.selectSingleNode("boarddata/@sid").text Boardreadme=Application(CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&BoardID&"']/@readme").text If Len(Board_Setting(22))< 24 Then Board_Setting(22)="1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1" OpenTime=Split(Board_Setting(22),"|") setting=Board_Setting(21) ischeck=Clng(Board_Setting(18)) If Board_Setting(50)<>"0" And Board_Setting(50)<>"" Then Set Dvbbs=Nothing:Response.Redirect Board_Setting(50) Else Forum_ads = Split(CacheData(2,0),"$") If Len(Forum_Setting(70))< 24 Then Forum_Setting(70)="1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1|1" OpenTime=Split(Forum_Setting(70),"|") setting=Forum_Setting(69) ischeck=Forum_Setting(26) If Not IsNumeric(ischeck) Then ischeck=0 ischeck=CLng(ischeck) End If '定时开放判断 If Not Page_Admin And Cint(setting)=1 Then If OpenTime(Hour(Now))="1" Then Response.redirect "showerr.asp?action=stop&boardid="&Dvbbs.BoardID&"" End If '在线人数限制 If ischeck > 0 And Not Page_Admin Then If MyBoardOnline.Forum_Online > ischeck And BoardID=0 Then If Not IsONline(Membername,1) Then Set Dvbbs=Nothing:Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck End If If BoardID > 0 Then If (Not IsONline(Membername,1)) And MyBoardOnline.Board_Online > ischeck Then Set Dvbbs=Nothing:Response.Redirect "showerr.asp?action=limitedonline&lnum="&ischeck End If End If Dim CookiesSid CookiesSid = Request.Cookies("skin")("skinid_"&BoardID) If CookiesSid = "" Then If BoardID = 0 Then SkinID = Main_Sid Else SkinID = Sid End If Else SkinID = CookiesSid End If Setting=empty End Sub Public Function IsReadonly() IsReadonly=False Dim TimeSetting If Forum_Setting(69)="2" Then TimeSetting=split(Forum_Setting(70),"|") If TimeSetting(Hour(Now))="1" Then IsReadonly=True Exit Function End If End If If BoardID>0 Then If Board_Setting(21)="2" Then TimeSetting=split(Board_Setting(22),"|") If TimeSetting(Hour(Now))="1" Then IsReadonly=True End If End If End Function Public Function IsONline(UserName,action) IsONline=False If Trim(UserName)="" Then Exit Function If IsObject(Session(CacheName & "UserID")) And action=1 Then IsONline=True:Exit Function End If Dim Rs Set Rs =Execute("Select UserID From Dv_Online Where Username='"&UserName&"'") If Not Rs.EOF Then IsONline=True Rs.close() Set rs=Nothing End Function Public Sub LoadTemplates(Page_Fields) Dim Style_Pic,Main_Style,TempStyle,cssfilepath Forum_PicUrl="skins/Default/" Template.TPLname=Page_Fields Dim Node Set Node=Application(CacheName &"_style").documentElement.selectSingleNode("style[@id='"& Skinid &"']") If(Node is Nothing) Then Set Node=Application(CacheName &"_style").documentElement.selectSingleNode("style") If (Node is Nothing) Then Response.Write "没有注册可用风格模板,请到后台设置" Response.End Else Skinid=node.selectSingleNode("@id").text End if End If Template.ChildFolder=CheckStr(node.getAttribute("folder")) If Template.ChildFolder="" Then Template.ChildFolder="template_1" if (lcase(Page_Fields)="index" or lcase(Page_Fields)="dispbbs" or lcase(Page_Fields)="showerr") Then Template.Cache=True ' End if If Not (Instr(ScriptName,"index")>0 Or Page_Admin) Then Dim FolderPath If MyDbPath = "../../../" Then FolderPath = "" Else FolderPath = MyDbPath End If Style_Pic = Dvbbs.ReadTextFile(FolderPath & Template.Folder &"\"& Template.ChildFolder &"\pub_FaceEmot.htm") 'Style_Pic = Dvbbs.ReadTextFile(Template.Folder &"\"& Template.ChildFolder &"\pub_FaceEmot.htm") Style_Pic = Split(Style_Pic,"@@@") Forum_UserFace = Style_Pic(0) Forum_PostFace = Style_Pic(1) Forum_Emot = Style_Pic(2) End If MainSetting = Split(MainHtml(0),"||") if ubound(MainSetting) >12 Then Forum_PicUrl=MainSetting(13) End Sub Public Function MainPic(Index) Dim Tplname,Cache Tplname=Template.TPLname Cache=Template.Cache Template.TPLname="pub" Template.Cache=true MainPic=Template.Pic(Index) Template.TPLname=Tplname Template.Cache=Cache End Function Public Function LanStr(Index) Dim Tplname,Cache Tplname=Template.TPLname Cache=Template.Cache Template.TPLname="pub" Template.Cache=true LanStr=Template.Strings(Index) Template.TPLname=Tplname Template.Cache=Cache End Function Public Function MainHtml(Index) Dim Tplname,Cache Tplname=Template.TPLname Cache=Template.Cache Template.TPLname="pub" Template.Cache=True MainHtml=Template.HTML(Index) Template.TPLname=Tplname Template.Cache=Cache End Function Rem 判断发言是否来自外部 Public Function ChkPost() Dim server_v1,server_v2 Chkpost=False server_v1=Cstr(Request.ServerVariables("HTTP_REFERER")) server_v2=Cstr(Request.ServerVariables("SERVER_NAME")) If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True End Function Public Sub ReloadSetupCache(MyValue,N)'更新总设置表部分缓存数组,入口:更新内容、数组位置 CacheData(N,0) = MyValue Name="setup" value=CacheData End Sub Public Sub NeedUpdateList(username,act)'更新用户资料缓存(缓存用户名,是否需要添加)[0=不添加,只作清理,1=需要添加] Dim Tmpstr,TmpUsername Name="NeedToUpdate" If ObjIsEmpty() Then Value="" Tmpstr=Value TmpUsername=","&username&"," Tmpstr=Replace(Tmpstr,TmpUsername,",") Tmpstr=Replace(Tmpstr,",,",",") If act=1 Then If IsONline(username,0) Then If Tmpstr="" Then Tmpstr=TmpUsername Else Tmpstr=Tmpstr&TmpUsername End If End If End If Tmpstr=Replace(Tmpstr,",,",",") Value=Tmpstr End Sub Public Sub LetGuestSession()'写入客人session Dim StatUserID,UserSessionID StatUserID = checkStr(Trim(Request.Cookies(Forum_sn)("StatUserID"))) If IsNumeric(StatUserID) = 0 or StatUserID = "" Then StatUserID = Replace(UserTrueIP,".","") UserSessionID = Replace(Startime,".","") If IsNumeric(StatUserID) = 0 or StatUserID = "" Then StatUserID = 0 StatUserID = Ccur(StatUserID) + Ccur(UserSessionID) End If StatUserID = Ccur(StatUserID) Response.Cookies(Forum_sn).Expires=DateAdd("s",3600,Now()) Response.Cookies(Forum_sn).path=cookiepath Response.Cookies(Forum_sn)("StatUserID") = StatUserID Set UserSession=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) UserSession.Loadxml guestxml UserSession.documentElement.selectSingleNode("userinfo/@statuserid").text=StatUserID UserSession.documentElement.selectSingleNode("userinfo/@cometime").text=Now() UserSession.documentElement.selectSingleNode("userinfo/@activetime").text=DateAdd("s",-3600,Now()) UserSession.documentElement.selectSingleNode("userinfo/@boardid").text=boardid Dim BS Set Bs=GetBrowser() UserSession.documentElement.appendChild(Bs.documentElement) If EnabledSession Then Session(CacheName & "UserID")=UserSession.xml End If End Sub '根据页面来判断是否需要执行TrueCheckUserLogin Public Function NeedChecklongin() NeedChecklongin=True If UserID > 0 Then If InStr(ScriptName,"admin_")>0 Then Exit Function Dim pagelist pagelist=",post.asp,usermanager.asp,mymodify.asp,modifypsw.asp,modifyadd.asp,usersms.asp," pagelist=pagelist & "friendlist.asp,favlist.asp,myfile.asp,friendlist.asp,recycle.asp," pagelist=pagelist & "fileshow.asp,bbseven.asp,dispuser.asp,savepost.asp,plus_tools_pay.asp,joinvipgroup.asp,plus_tools_center.asp" If InStr(pagelist,","&ScriptName&",")>0 Then Exit Function End If NeedChecklongin=False End Function '验证用户登陆 Public Sub CheckUserLogin() If EnabledSession Then Set UserSession=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) If Not UserSession.loadxml(Session(CacheName & "UserID")&"") Then If UserID > 0 Then TrueCheckUserLogin Else Call LetGuestSession() End If Else If UserID >0 Or UserSession.documentElement.selectSingleNode("userinfo/@userid").text<>"0" Then Dim NeedToUpdate,toupdate toupdate=False Name="NeedToUpdate" If Not ObjIsEmpty() Then NeedToUpdate=","&Value&"," If InStr(NeedToUpdate,","&MemberName&",")>0 Then Call NeedUpdateList(MemberName,0) toupdate=True End If End If If NeedChecklongin Or toupdate Then TrueCheckUserLogin Else End If End If Else If UserID > 0 Then TrueCheckUserLogin Else Call LetGuestSession() End If End If If UserID=0 Then UserToday = Split("0|0|0|0|0","|") End If UserID=CLng(UserSession.documentElement.selectSingleNode("userinfo/@userid").text) UserGroupID=CLng(UserSession.documentElement.selectSingleNode("userinfo/@usergroupid").text) If UserID > 0 Then GetCacheUserInfo Else UserGroupID = 7 Lastlogin = Now() End If Browser=Checkstr(UserSession.documentElement.selectSingleNode("agent/@browser").text) version=replace(Checkstr(UserSession.documentElement.selectSingleNode("agent/@version").text),"--","") platform=Checkstr(UserSession.documentElement.selectSingleNode("agent/@platform").text) If (Browser="unknown" And version="unknown" And platform="unknown") Or Request("IsSearch")="1" Then If IsWebSearch Then IsSearch = True Else IsSearch = False End If If Request("IsSearch") = "1" Then IsSearch = True Cls_IsSearch = True End If 'IP锁定 If UserSession.documentElement.selectSingleNode("agent/@lockip").text="1" Then If Not Page_Admin Then Set Dvbbs=Nothing:Response.Redirect "showerr.asp?action=iplock" End If Call GetGroupSetting() End Sub Rem xmlroot跟节点名称 row记录行节点名称 Public Function RecordsetToxml(Recordset,row,xmlroot) Dim i,node,rs,j,DataArray If xmlroot="" Then xmlroot="xml" If row="" Then row="row" Set RecordsetToxml=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot)) If Not Recordset.EOF Then DataArray=Recordset.GetRows(-1) For i=0 To UBound(DataArray,2) Set Node=RecordsetToxml.createNode(1,row,"") j=0 For Each rs in Recordset.Fields node.attributes.setNamedItem(RecordsetToxml.createNode(2,LCase(rs.name),"")).text= DataArray(j,i)& "" j=j+1 Next RecordsetToxml.documentElement.appendChild(Node) Next End If DataArray=Null End Function Public Function ArrayToxml(DataArray,Recordset,row,xmlroot) Dim i,node,rs,j If xmlroot="" Then xmlroot="xml" Set ArrayToxml=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) ArrayToxml.appendChild(ArrayToxml.createElement(xmlroot)) If row="" Then row="row" For i=0 To UBound(DataArray,2) Set Node=ArrayToxml.createNode(1,row,"") j=0 For Each rs in Recordset.Fields node.attributes.setNamedItem(ArrayToxml.createNode(2,LCase(rs.name),"")).text= DataArray(j,i)& "" j=j+1 Next ArrayToxml.documentElement.appendChild(Node) Next End Function Public Function Createpass()'系统分配随机密码 Dim Ran,i,LengthNum LengthNum=16 Createpass="" For i=1 To LengthNum Randomize Ran = CInt(Rnd * 2) Randomize If Ran = 0 Then Ran = CInt(Rnd * 25) + 97 Createpass =Createpass& UCase(Chr(Ran)) ElseIf Ran = 1 Then Ran = CInt(Rnd * 9) Createpass = Createpass & Ran ElseIf Ran = 2 Then Ran = CInt(Rnd * 25) + 97 Createpass =Createpass& Chr(Ran) End If Next End Function Public Sub NewPassword()'更新用户验证密码 If UserID=0 Then Exit Sub 'Response.Write "<iframe style=""border:0px;width:0px;height:0px;"" src=""newpass.asp"" name=""Dvnewpass""></iframe>" Dim TruePassWord,usercookies,i usercookies=Request.Cookies(Dvbbs.Forum_sn)("usercookies") TruePassWord=Dvbbs.Createpass If (Isnull(usercookies) or usercookies="") And Not Isnumeric(usercookies) Then usercookies=0 Call updateCookiesInfo(usercookies,TruePassWord) '检查写入是否成功如果成功则更新数据 i=0 Do While i<3 If Dvbbs.checkStr(Trim(Request.Cookies(Dvbbs.Forum_sn)("password")))=TruePassWord Then Dvbbs.Execute("Update [Dv_user] Set TruePassWord='"&TruePassWord&"' where UserID="&Dvbbs.UserID) Dvbbs.MemberWord = TruePassWord Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@truepassword").text= TruePassWord Exit Do Else Call updateCookiesInfo(usercookies,TruePassWord) End If i=i+1 Loop End Sub '更新用户Cookies信息 Sub updateCookiesInfo(usercookies,TruePassWord) Select Case Cint(usercookies) Case 0 Response.Cookies(Dvbbs.Forum_sn)("usercookies") = usercookies Case 1 Response.Cookies(Dvbbs.Forum_sn).Expires=Date+1 Response.Cookies(Dvbbs.Forum_sn)("usercookies") = usercookies Case 2 Response.Cookies(Dvbbs.Forum_sn).Expires=Date+31 Response.Cookies(Dvbbs.Forum_sn)("usercookies") = usercookies Case 3 Response.Cookies(Dvbbs.Forum_sn).Expires=Date+365 Response.Cookies(Dvbbs.Forum_sn)("usercookies") = usercookies End Select Response.Cookies(Dvbbs.Forum_sn).path=Dvbbs.cookiepath Response.Cookies(Dvbbs.Forum_sn)("username") = Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@username").text Response.Cookies(Dvbbs.Forum_sn)("UserID") = Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userid").text Response.Cookies(Dvbbs.Forum_sn)("userclass") = Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userclass").text Response.Cookies(Dvbbs.Forum_sn)("userhidden") = Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userhidden").text Response.Cookies(Dvbbs.Forum_sn)("password") = TruePassWord Response.Flush End Sub Public Sub TrueCheckUserLogin() Dim Rs,SQL,FoundMyGroupID FoundMyGroupID = 0 Sql="Select UserID,UserName,UserPassword,UserEmail,UserPost,UserTopic,UserSex,UserFace,UserWidth,UserHeight,JoinDate,LastMsg,LastLogin as cometime ,LastLogin,LastLogin as activetime,UserLogins,Lockuser,Userclass,UserGroupID,UserGroup,userWealth,userEP,userCP,UserPower,UserBirthday,UserLastIP,UserDel,UserIsBest,UserHidden,UserMsg,IsChallenge,UserMobile,TitlePic,UserTitle,TruePassWord,UserToday,UserMoney,UserTicket,FollowMsgID,Vip_StarTime,Vip_EndTime,userid as boardid,Usersetting" Sql=Sql & " From [Dv_User] Where UserID = " & UserID Set Rs = Execute(Sql) If Rs.EOF Then UserID = 0:LetGuestSession():Exit Sub Else If Not (LCase(Rs("UserName"))=LCase(Membername) and Rs("TruePassWord")=Memberword) Then If EnabledSession Then Set UserSession=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) If UserSession.loadxml(Session(CacheName & "UserID")&"") Then If UserSession.documentElement.selectSingleNode("userinfo/@username") Is Nothing Or UserSession.documentElement.selectSingleNode("userinfo/@userpassword") Is Nothing Then UserID = 0:LetGuestSession():Exit Sub Else If Not (LCase(Rs("UserName"))=LCase(UserSession.documentElement.selectSingleNode("userinfo/@username").text) and Rs("UserPassword")=UserSession.documentElement.selectSingleNode("userinfo/@userpassword").text) Then UserID = 0:LetGuestSession():Exit Sub End If End If Else UserID = 0:LetGuestSession():Exit Sub End If Else UserID = 0:LetGuestSession():Exit Sub End If End If If Rs("LockUser")=1 Then UserID = 0:LetGuestSession():Exit Sub End if End If Set UserSession = RecordsetToxml(rs,"userinfo","xml") UserSession.documentElement.selectSingleNode("userinfo/@cometime").text=Now() UserSession.documentElement.selectSingleNode("userinfo/@activetime").text=DateAdd("s",-3600,Now()) UserSession.documentElement.selectSingleNode("userinfo/@boardid").text=boardid UserSession.documentElement.selectSingleNode("userinfo").attributes.setNamedItem(UserSession.createNode(2,"isuserpermissionall","")).text=FoundUserPermission_All() Dim BS Set Bs=GetBrowser() UserSession.documentElement.appendChild(Bs.documentElement) If EnabledSession Then Session(CacheName & "UserID")= UserSession.xml End If Rs.close() Set Rs=Nothing GetCacheUserInfo() End Sub Public Sub GetCacheUserInfo() '用户登录成功后,采用本函数读取用户数组并判断一些常用信息 UserID = Clng(UserSession.documentElement.selectSingleNode("userinfo/@userid").text) MemberName = UserSession.documentElement.selectSingleNode("userinfo/@username").text Lastlogin = UserSession.documentElement.selectSingleNode("userinfo/@lastlogin").text LastMsg = UserSession.documentElement.selectSingleNode("userinfo/@lastmsg").text If Not IsDate(LastLogin) Then LastLogin = Now() If Not IsDate(LastMsg) Then LastMsg = LastLogin 'Response.write LastMsg & ".." & LastLogin 'Test UserGroupID = CLng(UserSession.documentElement.selectSingleNode("userinfo/@usergroupid").text) If Trim(UserSession.documentElement.selectSingleNode("userinfo/@usertoday").text)="" Then Execute("Update [Dv_User] Set UserToday='0|0|0|0|0' Where UserID = " & UserID) UserSession.documentElement.selectSingleNode("userinfo/@usertoday").text="0|0|0|0|0" UserToday = Split("0|0|0|0|0","|") Else UserToday = Split(UserSession.documentElement.selectSingleNode("userinfo/@usertoday").text,"|") If Ubound(UserToday) <> 4 Then Execute("Update [Dv_User] Set UserToday='0|0|0|0|0' Where UserID = " & UserID) UserSession.documentElement.selectSingleNode("userinfo/@usertoday").text="0|0|0|0|0" UserToday = Split("0|0|0|0|0","|") End If End If '判断是否VIP组成员 If IsDate(UserSession.documentElement.selectSingleNode("userinfo/@vip_startime").text) Then If DateDiff("d",Now(),UserSession.documentElement.selectSingleNode("userinfo/@vip_endtime").text)>0 Then VipGroupUser = True Else Dim tRs '将已过期的VIP用户移回注册组并清空有效时间 If UserGroupID>8 Then Set tRs=Execute("Select Top 1 * From Dv_UserGroups Where ParentGID=3 And MinArticle<="& CCur(UserSession.documentElement.selectSingleNode("userinfo/@userpost").text) &" Order By MinArticle Desc") If not tRs.Eof Then Execute("Update Dv_User Set UserClass='"&tRs("UserTitle")&"',TitlePic='"&tRs("GroupPic")&"',UserGroupID="&tRs("UserGroupID")&",Vip_StarTime=null,Vip_EndTime=null Where UserID="&UserID) End If Set tRs=Nothing Else Execute("Update Dv_User Set Vip_StarTime=null,Vip_EndTime=null Where UserID="&UserID) End If UserSession.documentElement.selectSingleNode("userinfo/@vip_startime").text = "" UserSession.documentElement.selectSingleNode("userinfo/@vip_endtime").text ="" End If End If Select Case UserGroupID Case 8 Vipuser = True Case 3 If BoardID=0 Then Boardmaster = True Case 2 Superboardmaster = True Boardmaster = True Case 1 Master = True Boardmaster = True End Select If UserSession.documentElement.selectSingleNode("userinfo/@ischallenge").text = "1" Then FoundIsChallenge = True If DateDiff("d",LastLogin,Now())<>0 Then '检查是否有新短信 Call TyUserMsg(Dvbbs.MemberName,0) Execute("Update [Dv_User] Set UserToday='0|0|0|0|0',LastLogin = " & SqlNowString & " Where UserID = " & UserID) UserSession.documentElement.selectSingleNode("userinfo/@usertoday").text = "0|0|0|0|0" LastLogin = Now() End If If Userhidden = 2 and DateDiff("s",Lastlogin,Now())>Clng(Forum_Setting(8))*60 Then '检查是否有新短信 Call TyUserMsg(Dvbbs.MemberName,0) Execute("Update [Dv_User] Set UserLastIP = '" & UserTrueIP & "',LastLogin = " & SqlNowString & " Where UserID = " & UserID) Lastlogin = Now() End If sendmsgnum=0:sendmsgid=0:sendmsguser="" If UserSession.documentElement.selectSingleNode("userinfo/@usermsg").text<>"" Then Dim Usermsg Usermsg=Split(UserSession.documentElement.selectSingleNode("userinfo/@usermsg").text,"||") If Ubound(Usermsg)=2 Then sendmsgnum=Usermsg(0) sendmsgid=Usermsg(1) sendmsguser=Usermsg(2) End If End If '跟踪用户处理 Dim FollowMsgID Set FollowMsgID=UserSession.documentElement.selectSingleNode("userinfo/@followmsgid") If Not ( FollowMsgID Is Nothing) Then If FollowMsgID.text <>"" Then Dim ToolsFollowUserID,i,Rs,Tools_inceptid,Tools_newincept,Tools_msginfo ToolsFollowUserID = Split( FollowMsgID.text,",") For i=0 To Ubound(ToolsFollowUserID) If Len(ToolsFollowUserID(i))>0 and Len(ToolsFollowUserID(i))<50 and ToolsFollowUserID(i)<>"" Then ToolsFollowUserID(i) = CheckStr(ToolsFollowUserID(i)) Execute("Insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"& ToolsFollowUserID(i)&"','系统消息','您跟踪的用户"&Dvbbs.MemberName&"已登录','您使用了论坛道具“狗仔队”,您所跟踪的用户 "&Dvbbs.Membername&" 于 "&Now()&" 登录了论坛,请您及时和该用户取得联系,感谢您采用我们的服务。',"&SqlNowString&",0,1)") Set Rs=Execute("Select top 1 id,sender From Dv_Message Where incept ='"& ToolsFollowUserID(i) &"'") Tools_inceptid=Rs(0) &"||"& Rs(1) Set Rs=Execute("Select Count(id) From Dv_Message Where Flag=0 and issend=1 and delR=0 And incept='"& ToolsFollowUserID(i) &"'") Tools_newincept = Rs(0) Rs.close() Set Rs=Nothing If IsNull(Tools_newincept) Then Tools_newincept=0 Tools_msginfo=Tools_newincept & "||" & Tools_inceptid Execute("update [dv_user] set UserMsg='"&CheckStr(Tools_msginfo)&"' where username='"&ToolsFollowUserID(i)&"'") End If Next FollowMsgID.text = "" Execute("UpDate Dv_User Set FollowMsgID='' Where UserID="&UserID) End If End If FoundUser=True UserSession.documentElement.selectSingleNode("userinfo/@lastlogin").text=Lastlogin Dim iUserMagicFace'用户头像处理 iUserMagicFace = Split(UserSession.documentElement.selectSingleNode("userinfo/@userface").text,"|") If Ubound(iUserMagicFace) = 1 Then UserSession.documentElement.selectSingleNode("userinfo/@userface").text = iUserMagicFace(1) End Sub Private Sub GetGroupSetting() If Not IsObject(Application(CacheName &"_groupsetting")) Then LoadGroupSetting() If Application(CacheName &"_groupsetting").documentElement.selectSingleNode("usergroup[@usergroupid='"& UserGroupID &"']/@groupsetting") Is nothing Then UserGroupID=7 GroupSetting = Split(Application(CacheName &"_groupsetting").documentElement.selectSingleNode("usergroup[@usergroupid='"& UserGroupID &"']/@groupsetting").text,",") TyReadOnly=False TyClsGroup=Cint(Application(CacheName &"_groupsetting").documentElement.selectSingleNode("usergroup[@usergroupid='"& UserGroupID &"']/@tyclsgroup").text) 'FIsh If ScriptName="reg.asp" or ScriptName ="login.asp" or Page_Admin Then GroupSetting(0)=1 If Cint(GroupSetting(0))=0 Then AddErrCode "8":Showerr() UserGroupParent = Cint(Application(CacheName &"_groupsetting").documentElement.selectSingleNode("usergroup[@usergroupid='"& UserGroupID &"']/@parentgid").text) If UserID > 0 Then IsUserPermissionAll = CLng(UserSession.documentElement.selectSingleNode("userinfo/@isuserpermissionall").text) If BoardID > 0 And Not ScriptName="showerr.asp" Then CheckBoardInfo() If UserID > 0 And BoardID=0 Then If IsUserPermissionAll="1" Then LoadUserPermission_All() End If Rem 判断用户组是否定时关闭访问 2010-2-2 动网.小易 TyClsGroupM=Application(CacheName &"_groupsetting").documentElement.selectSingleNode("usergroup[@usergroupid='"& UserGroupID &"']/@tyclsgroupm").text If TyClsGroup<>0 and boardid>0 Then Dim TyTmpTime TyTmpTime=split(TyClsGroupM,"|") if TyTmpTime(Hour(Now)) ="1" then TyReadOnly=True if TyClsGroup=1 Then Response.redirect "showerr.asp?ShowErrType="&Dvbbs.ErrType&"&action=stop" end if End If End Sub '用户是否存在论坛全局自定义权限 Public Function FoundUserPermission_All() Dim PerRs FoundUserPermission_All = 0 Set PerRs=Execute("Select Uc_Setting From Dv_UserAccess Where Uc_Boardid=0 And uc_UserID= "& UserID ) If Not (PerRs.Eof And PerRs.Bof) Then FoundUserPermission_All = 1 PerRs.Close:Set PerRs=Nothing End Function Public Sub LoadUserPermission_All() Dim Rs Set Rs=Dvbbs.execute("Select Uc_Setting From Dv_UserAccess Where Uc_Boardid=0 And uc_UserID="&UserID) If Not(Rs.Eof And Rs.Bof) Then UserPermission=Split(Rs(0),",") GroupSetting = Split(Rs(0),",") FoundUserPer=True End If Rs.close() Set Rs=Nothing End Sub Public Sub ActiveOnline() Response.Write "<script language=""JavaScript"">" Response.Write "setTimeout('ActiveOnline("&boardid&")',2000);" Response.Write "</script>" End Sub Rem 检查是否有群发短信,Dv.小易 Public Sub TyUserMsg(username,ChkNow) Dim TyRs,TySql,TyTmpStr,TyMsgInf,TyMsgNum,TyUpdateNeed,ChkMsgTime,TyMsgC,i ChkMsgTime= int(Dvbbs.forum_setting(115)) ' 多久检查一次是否有新短信,单位:分钟,如果ChkNow参数为0则即时检查 ChkMsgTime = ChkMsgTime * 60 if ChkNow = 1 Then ChkMsgTime = 0 if not isdate(LastMsg) Then LastMsg = UserSession.documentElement.selectSingleNode("userinfo/@lastmsg").text If DateDiff("s",LastMsg,now) < ChkMsgTime Then Exit Sub End If Set TyRs=Dvbbs.Execute("Select sender,Title,Content,sendtime From Dv_Message where incept =',"&UserGroupID&",'") '用户组 If TyRs.eof and TyRs.Bof Then TyRs.close set TyRs=nothing Exit Sub else TyMsgC=TyRs.GetRows(-1) TyRs.Close : Set TyRs = Nothing end if TyUpdateNeed= False If IsArray(TyMsgC) Then for i = 0 to ubound(TyMsgC,2) If DateDiff("s",LastMsg,TyMsgC(3,i)) > 0 Then TySql = "INSERT into dv_message(incept, sender, title, content, sendtime, flag, issend) values('"&username&"', '"&TyMsgC(0,i)&"', '"&TyMsgC(1,i)&"', '"&TyMsgC(2,i)&"', '"&TyMsgC(3,i)&"',0,1)" TyTmpStr="0||"&TyMsgC(1,i) Dvbbs.Execute(TySql) TyUpdateNeed = True End If Next end If If TyUpdateNeed Then TySql = "Select Count(id) from dv_Message Where flag=0 and issend=1 and delR=0 And incept='"& username &"'" Set TyRs=Dvbbs.Execute(TySql) TyMsgNum=TyRs(0) TyRs.close If IsNull(TyMsgNum) Then TyMsgNum=0 TyMsgInf=TyMsgNum&"||"&TyTmpStr Dvbbs.Execute("update [dv_user] set UserMsg='"&dvbbs.CheckStr(TyMsgInf)&"',LastMsg=" & SqlNowString & " where username='"&username&"'") Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermsg").text=TyMsgInf Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@lastmsg").text=Now() LastMsg=Now() End If set TyRs=nothing End Sub Public Sub ActiveOnline1() '当在120秒内刷新同一个页面则不更新online数据 If Not IsNumeric(UserSession.documentElement.selectSingleNode("userinfo/@boardid").text) Or UserSession.documentElement.selectSingleNode("userinfo/@boardid").text="" Then UserSession.documentElement.selectSingleNode("userinfo/@boardid").text="0" If DateDiff("s",UserSession.documentElement.selectSingleNode("userinfo/@activetime").text,Now()) < 120 And CLng(UserSession.documentElement.selectSingleNode("userinfo/@boardid").text) = BoardID And Not InStr(ScriptName,"showerr")>0 Then Exit Sub '更新数组 UserSession.documentElement.selectSingleNode("userinfo/@activetime").text=Now() UserSession.documentElement.selectSingleNode("userinfo/@boardid").text=boardid UserActiveOnline '新增更新用户最后登录时间,以保证贴子中在线判断的准确性 If UserSession.documentElement.selectSingleNode("userinfo/@userid").text <> "0" Then If UserSession.documentElement.selectSingleNode("userinfo/@userhidden").text="2" Then '检查是否有新短信 Call TyUserMsg(Dvbbs.MemberName,0) Execute("update [Dv_user] set lastlogin=" & SqlNowString & " where userid="&Dvbbs.userid) End If End If End Sub Private Sub UserActiveOnline() Dim Actcome,SQl,Rs Dim uip,StatsStr uip = UserTrueIP StatsStr = Stats StatsStr = Replace(StatsStr, "'", "") StatsStr = Replace(StatsStr, Chr(0), "") StatsStr = Replace(StatsStr, "--", "——") StatsStr = Left(StatsStr, 250) If UserID = 0 Then Dim StatUserID StatUserID = UserSession.documentElement.selectSingleNode("userinfo/@statuserid").text SQL = "Select ID,Boardid From [Dv_Online] Where ID = " & Ccur(StatUserID) Set Rs = Execute(SQL) If Rs.EOF Then If IP_MAX>0 Then If Onlineip(UserTrueIP) > IP_MAX Then Session(CacheName & "UserID")=empty Set Dvbbs=Nothing Response.Status = "302 Object Moved" Response.End End If End if If CInt(Forum_Setting(36)) = 0 Then Actcome = "" Else Actcome = address(uip) End If If Cls_IsSearch Then Exit Sub SQL = "Insert Into [Dv_Online](ID,Username,Userclass,Ip,Startime,Lastimebk,Boardid,Browser,Stats,Usergroupid,Actcome,Userhidden,actforip) Values (" & StatUserID & ",'客人','客人','" & UserTrueIP & "'," & SqlNowString & "," & SqlNowString & "," & Boardid & ",'" & platform&"|"&Browser&version & "','" & StatsStr & "',7,'" & Actcome & "'," & Userhidden & ",'"& checkstr(actforip)&"')" '更新缓存总在线数据 MyBoardOnline.Forum_Online=MyBoardOnline.Forum_Online+1 Name="Forum_Online" value=MyBoardOnline.Forum_Online Else Dim TempUserInfo,TempHidden Set TempUserInfo=UserSession.documentElement.selectSingleNode("userinfo") If TempUserInfo Is Nothing Then TempHidden=2 Else TempHidden=Dvbbs.CheckNumeric(TempUserInfo.getAttribute("userhidden")) End If SQL = "Update [Dv_Online] Set Lastimebk = " & SqlNowString & ",Boardid = " & Boardid & ",Stats = '" & StatsStr & "',Userhidden="&TempHidden&" Where ID = " & Ccur(StatUserID) End If Rs.Close Set Rs = Nothing Execute(SQL) Else SQL = "Select ID,Boardid From [DV_Online] Where UserID = " & UserID Set Rs = Execute(SQL) If Rs.Eof And Rs.Bof Then If CInt(forum_setting(36)) = 0 Then Actcome = "" Else Actcome = address(uip) End If SQL = "Insert Into [Dv_Online](ID,Username,Userclass,Ip,Startime,Lastimebk,Boardid,Browser,Stats,Usergroupid,Actcome,Userhidden,UserID,actforip) Values (" & Session.SessionID & ",'" & Membername & "','" & Memberclass & "','" & UserTrueIP & "'," & SqlNowString & "," & SqlNowString & "," & Boardid & ",'" & platform&"|"&Browser&version & "','" & StatsStr & "'," & UserGroupID & ",'" & Actcome & "'," & Userhidden & "," & UserID & ",'"& checkstr(actforip)&"')" '更新缓存总在线数据 MyBoardOnline.Forum_Online=MyBoardOnline.Forum_Online+1 Name="Forum_Online" Dvbbs.value=MyBoardOnline.Forum_Online '更新缓存总用户在线数据 MyBoardOnline.Forum_UserOnline=MyBoardOnline.Forum_UserOnline+1 Name="Forum_UserOnline" value=MyBoardOnline.Forum_UserOnline Else SQL = "Update [Dv_Online] Set Lastimebk = " & SqlNowString & ",Boardid = " & Boardid & ",Stats = '" & StatsStr & "' Where UserID = " & UserID End If Rs.Close Set Rs = Nothing Execute(SQL) End If '更新在线峰值 If CLng(MyBoardOnline.Forum_Online) > CLng(Maxonline) Then Execute("update [Dv_setup] set Forum_Maxonline="&CLng(MyBoardOnline.Forum_Online)&",Forum_MaxonlineDate="& SqlNowString) CacheData(5,0)=MyBoardOnline.Forum_Online CacheData(6,0)=Now() Name="setup" value=CacheData End If Rem 删除超时用户 MyBoardOnline.OnlineQuery End Sub Function Onlineip(ip) Dim SQl SQL="Select Count(*) From Dv_online where ip='"&ip&"'" Onlineip=Execute(SQL)(0) If IsNull(Onlineip) Then Onlineip=0 End Function Public Sub Nav() Head() ShowTopTable() IsTopTable = 1 End Sub Private Function GetBody(RootID) Dim TableName TableName=Execute("Select PostTable from dv_topic where topicid="&RootID&"")(0) GetBody=Execute("Select body from "&TableName&" where rootid="&RootID&" and parentid=0")(0) End Function '搜索引擎优化部分 Public Sub head() Dim description,keyword Response.Write MainHtml(18) Nowstats=stats keyword=Replace(Forum_info(8),"|",",") description=Forum_info(10) If ScriptName="index.asp" Then If BoardType<>"" Then Stats=Replacehtml(BoardType & " - " ) keyword=Replacehtml(BoardType) description=Left(Replacehtml(BoardType & " " & boardreadme),60) Else keyword=Replacehtml(Replace(Forum_info(8),"|",",")) description=(Left(Replacehtml(Forum_info(10)),60)) End if ElseIf ScriptName <> "dispbbs.asp" Then If BoardType<>"" Then Stats=Replacehtml(BoardType&("-"&Stats)) Elseif scriptname="dispbbs.asp" Then If BoardType<>"" Then Stats=Replacehtml(Stats & " - " & BoardType & " - ") keyword=Replacehtml(Nowstats & " " & BoardType) description=Left(Replacehtml(BoardType & " " & GetBody(CheckNumeric(Request("ID")))),60) End if End If '当页面处于帖子页面,简介判断 Stats=Replace(Stats,Chr(13),"") stats=Replacehtml(stats) If Request("IsSearch_a") <> "" Then stats = stats & "-网站地图" Nowstats=Replacehtml(Nowstats) If IsSearch Then Response.Write Replace(Replace(Replace(MainHtml(1),"{$keyword}",keyword & Replace(Forum_info(8),"|",",")),"{$description}",description),"{$title}",stats & Forum_Info(0) & " " & Forum_setting(111) & " -- Powered By Dvbbs.net," & Now()) Else Response.Write Replace(Replace(Replace(MainHtml(1),"{$keyword}",keyword),"{$description}",description),"{$title}",(stats & Forum_Info(0) & " - "&Forum_setting(111) )) End If '搜索引擎优化结束-0909 If Boardid=0 Then Response.Write "<link title="""& Forum_Info(0) &"-频道列表"" type=""application/rss+xml"" rel=""alternate"" href=""rssfeed.asp"" />" Response.Write Chr(10) Response.Write "<link title="""& Forum_Info(0) &"-最新20篇论坛主题"" type=""application/rss+xml"" rel=""alternate"" href=""rssfeed.asp?rssid=4"" />" Else Response.Write "<link title="""& Replacehtml(BoardType) &"-最新20篇论坛主题"" type=""application/rss+xml"" rel=""alternate"" href=""rssfeed.asp?boardid="&boardid&"&rssid=4"" />" End If Response.Write Chr(10) Response.Write MainHtml(2) Dim node,XMLDOM If Not Cls_IsSearch Then Response.Write "<script language=""javascript"" type=""text/javascript"">" Response.Write "var boardxml='',ISAPI_ReWrite = "&isUrlreWrite&",forum_picurl='"&Forum_PicUrl&"';" Response.Write "</script>" Else Exit Sub End If If Forum_Setting(19)="1" And Not Page_Admin Then If ( Trim(Forum_Setting(64))<>"" And InStr(LCase(Forum_Setting(64)),ScriptName) >0 And Cint(Forum_Setting(20))>0) Then If DateDiff("s",UserSession.documentElement.selectSingleNode("userinfo/@activetime").text,Now())< Cint(Forum_Setting(20)) and boardid=CLng(UserSession.documentElement.selectSingleNode("userinfo/@boardid").text) and InStr(LCase(Cstr(Request.ServerVariables("HTTP_REFERER"))),ScriptName) > 0 Then Response.Write "<div style=""margin-top:24px;text-align:left;text-indent :24px;"">本页面启用了防刷新设置,请不要在"& Forum_Setting(20) &"秒内连续刷新本页面.</div>" Response.Write "<div style=""text-align:left;text-indent :24px;"">"&(Forum_Setting(20)-DateDiff("s",UserSession.documentElement.selectSingleNode("userinfo/@activetime").text,Now()))&"秒后将重新加载页面请稍等....</div>" Response.Write "<script language=""javascript"" type=""text/javascript"">" Response.Write "setTimeout('location.reload();',"&(Forum_Setting(20)-DateDiff("s",UserSession.documentElement.selectSingleNode("userinfo/@activetime").text,Now()))*1000&");" Response.Write "</script>" Response.Write "</body></html>" Set Dvbbs=Nothing Response.End Else UserSession.documentElement.selectSingleNode("userinfo/@activetime").text=Now() UserSession.documentElement.selectSingleNode("userinfo/@boardid").text=Boardid End If End If End If End Sub Public Sub ShowTopTable() Dim TempStr,ForumMenu,Tempstr1 Dim RayMenuInfo,RayMenu If IsSearch Then '搜索引擎优化部分 '加入针对搜索引擎的导航栏,同时增加官方链接(可增加自身网站PageRank以及给官方增加搜索引擎友好度),请勿擅自取消 sysmenu = MainHtml(20) Dim node,XMLDom,iTempStr Set XMLDOM=Application(Dvbbs.CacheName&"_boardlist") iTempStr = " " For each node in XMLDOM.documentElement.selectNodes("board[@parentid=0]") iTempStr = iTempStr & ("<a href=""index.asp?IsSearch_a=2&BoardID="&Node.selectSingleNode("@boardid").text&""">" & Node.selectSingleNode("@boardtype").text & "</a> ") Next sysmenu = Replace(sysmenu,"{$catlist}",(iTempStr & "<a href=""http://www.cndw.com"" title=""论坛,bbs,免费论坛,国内最大的论坛软件服务提供商,blog,boke,博客,防火墙,插件"">动网论坛</a> <a href=""http://bbs.cndw.com"" title=""论坛,bbs,免费论坛,国内最大的论坛软件服务提供商官方讨论区,blog,boke,博客,asp,asp.net,电脑,软件,灌水,防火墙,开发,插件"">官方论坛</a> <a href=http://tool.cndw.com>站长工具</a>")) '搜索引擎优化结束 ElseIf UserID = 0 Then sysmenu = MainHtml(7) Else sysmenu = Replace(MainHtml(6),"{$username}",Membername) If UserHidden=2 Then sysmenu = Replace(sysmenu,"{$hiddeninfo}",LanStr(3)) Else sysmenu = Replace(sysmenu,"{$hiddeninfo}",LanStr(4)) End If Rem 导航栏显示短信信息 Fish If sendmsgnum>0 Then sysmenu = Replace(sysmenu,"{$TyMsgStr}"," 收件箱(<b style='color:red'>"&sendmsgnum&"</b>) ") Else sysmenu = Replace(sysmenu,"{$TyMsgStr}"," 收件箱(0) ") End If If Master Or GroupSetting(70)="1" Then sysmenu = Replace(sysmenu,"{$manageinfo}",MainHtml(10)) ElseIf Superboardmaster Then sysmenu = Replace(sysmenu,"{$manageinfo}",MainHtml(19)) Else sysmenu = Replace(sysmenu,"{$manageinfo}","") End If sysmenu = Replace(sysmenu,"{$raymenuinfo}","") sysmenu = Replace(sysmenu,"{$userid}",UserID) End If Tempstr1 = Replace(MainHtml(17),"{$boardid}",boardid) If (Dvbbs.Forum_ChanSetting(13)="1" And Dvbbs.Forum_ChanSetting(0)="1") Or Dvbbs.Forum_ChanSetting(3)="0" Then Tempstr1 = Replace(Tempstr1,"{$UserTicket}",("<br />" & LanStr(11))) Else Tempstr1 = Replace(Tempstr1,"{$UserTicket}","") End If Tempstr1=Split(Tempstr1&"","||") If UBound(Tempstr1)=2 Then sysmenu = Replace(sysmenu&"","{$menu_membertools}",Tempstr1(0)) sysmenu = Replace(sysmenu&"","{$menu_show}",Tempstr1(2)) Else sysmenu = Replace(sysmenu&"","{$menu_membertools}","") sysmenu = Replace(sysmenu&"","{$menu_show}","") End If If Dvbbs.Forum_setting(99) = "1" Then sysmenu = Replace(sysmenu,"{$isboke}",MainHtml(21)) Else sysmenu = Replace(sysmenu,"{$isboke}","") End If If Forum_Setting(90)=0 Then sysmenu = Replace(sysmenu,"{$Plus_Tools}","") Else sysmenu = Replace(sysmenu,"{$Plus_Tools}",MainHtml(16)) End If If Forum_Setting(104)=0 Then sysmenu = Replace(sysmenu,"{$Ty_medal}","") Else sysmenu = Replace(sysmenu,"{$Ty_medal}","<a href='medal_index.asp'>荣誉勋章</a><br/>") End If If GroupSetting(57) = "1" Then Name = "style_list" Tempstr1=replace(Value,"$boardid",boardid) If Dvbbs.BoardID = 0 Then TempStr1 = Replace(TempStr1,"{$dskinid}",CacheData(17,0)) Else TempStr1 = Replace(TempStr1,"{$dskinid}",Sid) End If Else Dim MainHtml_9 MainHtml_9=MainHtml(9) MainHtml_9 = Split(MainHtml_9,"||") Tempstr1=Replace(Replace(MainHtml_9(0),"{$dskinid}",CacheData(17,0)),"{$csslist}","") End If sysmenu = Replace(sysmenu,"{$syles}",Tempstr1) TempStr = TempStr & (Chr(10) & MainHtml(4)) TempStr = Replace(TempStr,"{$width}",MainSetting(0)) TempStr = Replace(TempStr,"{$link}",Forum_Info(1)) If Boardid>0 Then If Board_Setting(51)="" Or Board_Setting(51) = "0" Then TempStr = Replace(TempStr,"{$logo}",Forum_Info(6)) Else TempStr = Replace(TempStr,"{$logo}",Board_Setting(51)) End If Else TempStr = Replace(TempStr,"{$logo}",Forum_Info(6)) End If If Trim(Forum_info(7))<>"0" And Trim(Forum_info(7))<>"" Then TempStr = Replace(TempStr,"{$mailto}",Forum_Info(7)) Else TempStr = Replace(TempStr,"{$mailto}",("mailto:" & Forum_Info(5))) End If TempStr = Replace(TempStr,"{$title}",(Forum_Info(0) & "-" & Replace(stats,"'","\'"))) TempStr = Replace(TempStr,"{$top_ads}",Forum_ads(0)) TempStr = Replace(TempStr,"{$menu}",Chr(10) & sysmenu) TempStr = Replace(TempStr,"{$boardid}",boardid) TempStr = Replace(TempStr,"{$alertcolor}",MainSetting(1)) Name = "ForumPlusMenu" If ObjIsEmpty Then LoadPlusMenu() ForumMenu = Value If ForumMenu <> "" Then TempStr = Replace(TempStr,"{$plusmenu}",ForumMenu) Else TempStr = Replace(TempStr,"{$plusmenu}","") End If Response.Write TempStr TempStr = "" If Request.Cookies("geturl")<>Request.ServerVariables("PATH_INFO")&"?"&Request.QueryString Then Response.Cookies("geturl") = Request.ServerVariables("PATH_INFO")&"?"&Request.QueryString End If End Sub Public Sub Head_var(IsBoard,idepth,GetTitle,GetUrl) Dim NavStr,AllBoardList If Dvbbs.BoardID=0 Then BoardReadme=LanStr(2) & " <b>" & Forum_Info(0) & "</b>" If BoardID>0 Then '是否加载首页版块导航,当版块太多时加载会慢,建议关闭此功能 by 牛头 Dim isindexmenu If Dvbbs.Checknumeric(Dvbbs.forum_setting(112))-0=0 Then isindexmenu=" onmouseover=""showmenu(event,BoardJumpList(0),'',0);""" Else isindexmenu="" End If NavStr = " <a href="""&(Forum_Info(11)&"""" & isindexmenu &" style=""cursor:hand;""><b>"&Forum_info(0)&"</b></a> → ") Else NavStr = " <a href="""&(Forum_Info(11)&""">"&Forum_info(0)&"</a> → ") End If If IsBoard=1 Then If BoardParentID=0 Then NavStr = NavStr & (" <a href=""index.asp?boardid="&BoardID&""" onMouseOver=""showmenu(event,BoardJumpList("&Dvbbs.Boardid&"),'',0);"">"&BoardType&"</a>") 'NavStr = NavStr & ("<li class=""mainmenu_li"" onmouseover=""appMenu(this,0,"&BoardID&");""><a href=""index.asp?boardid="&BoardID&""">"&BoardType&"</a> <div class=""submenu"" onmouseout=""hidemenu(1);hidemenu(0)""></div></li>") Else If ScriptName="dispbbs.asp" Then NavStr = NavStr & (BoardInfoData & " → <a href=""index.asp?boardid="&BoardID&"&page="&Request("page")&""">"&BoardType&"</a>") Else NavStr = NavStr & (BoardInfoData & " → <a href=""index.asp?boardid="&BoardID&""">"&BoardType&"</a>") End If End If NavStr = NavStr & (" → " & Nowstats) Elseif IsBoard=2 Then NavStr = NavStr & Nowstats Else NavStr = NavStr & ("<a href="&GetUrl&">"&GetTitle&"</a> → " & Nowstats) End If NavStr = Replace(MainHtml(5),"{$nav}",NavStr) NavStr = Replace(NavStr,"{$width}",MainSetting(0)) NavStr = Replace(NavStr,"{$boardreadme}",BoardReadme) If ScriptName="dispbbs.asp" Then If Second(Now()) Mod 2 = 0 Then NavStr = Replace(NavStr,"{$SearchStr}","<a href=""query.asp?stype=8&keyword="&Server.HtmlEncode(Nowstats&"")&"&isWeb=2"" target=""_blank"" title=""在更多网站中搜索此类问题,搜索和查看更多相关的精彩主题""><font color=""green""><b>搜一搜更多此类问题</b></font></a>") Else NavStr = Replace(NavStr,"{$SearchStr}","<a href=""query.asp?stype=8&keyword="&Server.HtmlEncode(Nowstats&"")&"&isWeb=2"" target=""_blank"" title=""在更多网站中搜索此类问题,搜索和查看更多相关的精彩主题""><font class=""redfont""><b>搜一搜相关精彩主题</b></font></a>") End If Else NavStr = Replace(NavStr,"{$SearchStr}","") End If If UserID>0 Then 'sendmsgnum,sendmsgid,sendmsguser IsBoard = Split(MainHtml(12),"||") If Clng(SendMsgNum)>0 Then BoardReadme = IsBoard(0) If Forum_Setting(10)=1 Then BoardReadme = BoardReadme & IsBoard(1) & IsBoard(2) Else BoardReadme = BoardReadme & IsBoard(2) End If BoardReadme = Replace(BoardReadme,"{$smsid}",sendmsgid) BoardReadme = Replace(BoardReadme,"{$sender}",sendmsguser) BoardReadme = Replace(BoardReadme,"{$newmsgnum}",sendmsgnum) Else BoardReadme = IsBoard(3) End If Dim i,UserGroupList,iGroupName NavStr = Replace(NavStr,"{$umsg}",BoardReadme) Else NavStr = Replace(NavStr,"{$umsg}","") End If NavStr = Replace(NavStr,"{$alertcolor}",MainSetting(1)) NavStr = Replace(NavStr,"{$showstr}","") 'NavStr =NavStr&"</li>" Response.Write ArchiveHtml((vbNewLine & NavStr)) End Sub Public Sub AddErrCode(ErrCode) If ErrCodes = "" Then ErrCodes = ErrCode Else ErrCodes = ErrCodes & "," & ErrCode End If End Sub Public Property Let ErrType(ByVal Value) ShowErrType = Value End Property Public Property Get ErrType() ErrType = ShowErrType End Property Public Sub Showerr() If ErrCodes<>"" Then If Stats="" Then If BoardID=0 Then Stats="访问"& Forum_Info(0) Else Stats="访问"& BoardType End If End If Dim parameter If ShowErrType = 1 Then parameter = MyDbPath& "showerr.asp?BoardID="&Boardid&"&ErrCodes="&ErrCodes&"&action="&server.URLEncode(Stats)&"&ShowErrType=1" PageEnd() Response.redirect parameter Else parameter = MyDbPath& "showerr.asp?BoardID="&Boardid&"&ErrCodes="&ErrCodes&"&action="&server.URLEncode(Stats) PageEnd() Response.redirect parameter End If End If End Sub Public Sub Showmessanger(title,messangertext) Response.Write "<div style=""position:absolute;top:220px;right:10px;width:350px;height : 90px;background:#fff;border: 5px solid #e4e8ef; "" id=""dv_msg"">" Response.Write "<div class=""th""><div>"&title&"</div></div>" Response.Write "<div class=""mainbar3"" style=""height : 36px;overflow :auto;"">" Response.Write messangertext Response.Write "</div>" Response.Write "<div class=""mainbar2"" style=""height : 20px;line-height : 20px;""><input type=""button"" value="" 关闭 "" onclick=""document.getElementById('dv_msg').style.visibility='hidden';"" />" Response.Write "</div></div>" End Sub Public Sub Footer() Dim Tmp,node If IsTopTable=1 Then If UserID>0 Then If IsObject( Application(Dvbbs.CacheName&"_messanger")) Then Set Node=Application(Dvbbs.CacheName&"_messanger").documentElement.selectSingleNode("messanger[@touserid="&userid&"]") If Not Node is Nothing Then Showmessanger Node.selectSingleNode("@senduser").text,Node.text Application(Dvbbs.CacheName&"_messanger").documentElement.removeChild(Node) End If End If End If Tmp = MainHtml(8) If Forum_Setting(30) = "1" Then Dim Endtime Endtime = Timer() Tmp = Replace(Tmp,"{$runtime}","页面执行时间 0"&FormatNumber((Endtime-Startime),5)&" 秒, "&SqlQueryNum&" 次数据查询<br />") Else Tmp = Replace(Tmp,"{$runtime}","") End If Dim Alibaba_Ad If IsSqlDataBase = 0 Or (IsBuss = 0 And IsSqlDataBase = 1) Or Forum_Info(0)="动网先锋论坛" Then Alibaba_Ad = "<div></div>" End If Tmp = Replace(Tmp,"{$powered}","Powered By <a href = ""http://www.dvbbs.net/"" target = ""_blank"">Dvbbs</a> <a href = ""http://www.dvbbs.net/download.asp"" target = ""_blank"">Version " & fVersion & "</a>" ) If Dvbbs.Forum_ChanSetting(3)="0" Then Tmp = Replace(Tmp,"{$alipaymsg}","") Else Tmp = Replace(Tmp,"{$alipaymsg}","") End If Tmp = Replace(Tmp,"{$Footer_ads}",Forum_ads(1) & Alibaba_Ad) Tmp = Replace(Tmp,"{$copyright}",Forum_Copyright) Tmp = Replace(Tmp,"{$boardid}",BoardID) Else Tmp ="</body></html>" End If Response.Write Tmp End Sub Public Sub Dvbbs_Suc(sucmsg) Dim TempStr TempStr = MainHtml(13) TempStr = Replace(TempStr,"{$sucmsg}",sucmsg) TempStr = Replace(TempStr,"{$returnurl}",Request.ServerVariables("HTTP_REFERER")) Response.Write TempStr TempStr = "" End Sub Public Function Execute(Command) If Not IsObject(Conn) Then ConnectionDatabase If IsDeBug = 0 Then On Error Resume Next Set Execute = Conn.Execute(Command) If Err Then err.Clear Set Conn = Nothing Response.Write "查询数据的时候发现错误,请检查您的查询代码是否正确。" Response.End End If Else If ShowSQL=1 Then Response.Write command & "<br>" End If Set Execute = Conn.Execute(Command) End If SqlQueryNum = SqlQueryNum+1 End Function '----------------------------------------------------------------------------------------------------- '独立道具查询 Public Function Plus_Execute(Command) If Cint(Forum_Setting(92))=1 Then If Not IsObject(Plus_Conn) Then Plus_ConnectionDatabase Else If Not IsObject(Conn) Then ConnectionDatabase End If If IsDeBug = 0 Then On Error Resume Next If Cint(Forum_Setting(92))=1 Then Set Plus_Execute = Plus_Conn.Execute(Command) Else Set Plus_Execute = Conn.Execute(Command) End If If Err Then err.Clear If Cint(Forum_Setting(92))=1 Then Set Plus_Conn = Nothing Else Set Conn = Nothing End If Response.Write "查询数据的时候发现错误,请检查您的查询代码是否正确。" Response.End End If Else 'Response.Write command & "<br>" If Cint(Forum_Setting(92))=1 Then Set Plus_Execute = Plus_Conn.Execute(Command) Else Set Plus_Execute = Conn.Execute(Command) End If End If SqlQueryNum = SqlQueryNum+1 End Function 'IP/来源 Public Function address(sip) Dim aConnStr,aConn,adb Dim str1,str2,str3,str4 Dim num Dim country,city Dim irs,SQL address="未知" If IsNumeric(Left(sip,2)) Then If sip="127.0.0.1" Then sip="192.168.0.1" str1=Left(sip,InStr(sip,".")-1) sip=mid(sip,instr(sip,".")+1) str2=Left(sip,instr(sip,".")-1) sip=Mid(sip,InStr(sip,".")+1) str3=Left(sip,instr(sip,".")-1) str4=Mid(sip,instr(sip,".")+1) If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then Else num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1 adb = "data/ipaddress.mdb" aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb) Set AConn = Dvbbs.iCreateObject("ADODB.Connection") aConn.Open aConnStr country="亚洲" city="" sql="select top 1 country,city from dv_address where ip1 <="& num &" and ip2 >="& num Set irs=aConn.execute(sql) If Not(irs.EOF And irs.bof) Then country=irs(0) city=irs(1) End If irs.close Set irs=Nothing aConn.Close Set aConn = Nothing SqlQueryNum = SqlQueryNum+1 End If address=country&city End If End Function '显示验证码 Public Function GetCode() GetCode= Dvbbs.MainHtml(15) End Function Public Function GetCode2() GetCode2= Dvbbs.MainHtml(25) End Function '检查验证码是否正确 modifty by reoaiq at 091020 Public Function CodeIsTrue() Dim CodeStr If LCase(CStr(Request.form("winaction")))="winaction" Then If forum_setting(120)="1" Then CodeStr=CStr(Lcase(Trim(request.Form("codestryuyinwin")))) Else CodeStr=CStr(Lcase(Trim(request.Form("codestrwin")))) End If Else If forum_setting(120)="1" Then CodeStr=CStr(Lcase(Trim(Request.Form("codestryuyin")))) Else CodeStr=CStr(Lcase(Trim(Request.Form("codestr")))) End If End If If Session("GetCode")=CodeStr And CodeStr<>"" Then CodeIsTrue=True Session("GetCode")=empty Else CodeIsTrue=False Session("GetCode")=empty End If End Function '去掉HTML标记 Public Function Replacehtml(Textstr) Dim Str,re Str=Textstr Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="<(.[^>]*)>" Str=re.Replace(Str, "") Set Re=Nothing Replacehtml=Str End Function '用于用户发布的各种信息过滤,带脏话过滤 Public Function HTMLEncode(fString) If Not IsNull(fString) Then fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") fString = Replace(fString, CHR(32), " ") ' fString = Replace(fString, CHR(9), " ") ' fString = Replace(fString, CHR(34), """) 'fString = Replace(fString, CHR(39), "'") '单引号过滤 fString = Replace(fString, CHR(13), "") fString = Replace(fString, CHR(10) & CHR(10), "</p><p> ") fString = Replace(fString, CHR(10), "<br/> ") fString=ChkBadWords(fString) HTMLEncode = fString End If End Function '用于用户发布的各种信息过滤,带脏话过滤 不过滤HTML 用于 公告 短信 小字报等 Public Function TextEnCode(fString) If Not IsNull(fString) Then fString = Replace(fString, CHR(32), " ") fString = Replace(fString, CHR(9), " ") fString = Replace(fString, CHR(13), "") fString = Replace(fString, CHR(10) & CHR(10), "</P><P>") fString = Replace(fString, CHR(10), "<br/>") fString=ChkBadWords(fString) TextEnCode = fString End If End Function '用于论坛本身的过滤,不带脏话过滤 Public Function iHTMLEncode(fString) If Not IsNull(fString) Then fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") fString = Replace(fString, CHR(32), " ") fString = Replace(fString, CHR(9), " ") fString = Replace(fString, CHR(34), """) 'fString = Replace(fString, CHR(39), "'") fString = Replace(fString, CHR(13), "") fString = Replace(fString, CHR(10) & CHR(10), "</p><p> ") fString = Replace(fString, CHR(10), "<br/> ") iHTMLEncode = fString End If End Function Public Function CheckNumeric(Byval CHECK_ID) If CHECK_ID<>"" and IsNumeric(CHECK_ID) Then _ CHECK_ID = cCur(CHECK_ID) _ Else _ CHECK_ID = 0 CheckNumeric = CHECK_ID End Function Public Function strLength(str) If isNull(str) Or Str = "" Then StrLength = 0 Exit Function End If Dim WINNT_CHINESE WINNT_CHINESE=(len("例子")=2) If WINNT_CHINESE Then Dim l,t,c Dim i l=len(str) t=l For i=1 To l c=asc(mid(str,i,1)) If c<0 Then c=c+65536 If c>255 Then t=t+1 Next strLength=t Else strLength=len(str) End If End Function Function strCut(str,strlen) Dim l,t,c,i 'On Error Resume Next str = Replacehtml(str) Rem 去掉HTML标记 l=len(str):t=0 For i=1 To l c=Abs(Asc(Mid(str,i,1))) If c>255 Then t=t+2 Else t=t+1 End If If t>=strlen Then strCut=left(str,i)&"..." Exit Function Else strCut=str End If Next strCut=Left(str,strlen) End Function Function GetIndex(S) Dim i GetIndex=-1 For i = 0 To UBound(BadWords) if(BadWords(i)=s) Then GetIndex=i Exit For End If Next End Function Public Function ChkBadWords(Str) If IsNull(Str) Then Exit Function Dim i For i = 0 To UBound(BadWords) If InStr(Str,BadWords(i))>0 Then If i > UBound(rBadWord) Then Str = Replace(Str,BadWords(i),"*") Else Str = Replace(Str,BadWords(i),rBadWord(i)) End If End If Next ChkBadWords = Str End Function Public Function Checkstr(Str) If Isnull(Str) Then CheckStr = "" Exit Function End If Str = Replace(Str,Chr(0),"") CheckStr = Replace(Str,"'","''") End Function Public Sub ReloadBoardCache(lboardid) Dim Boardidlist,bid Boardidlist=Split(lboardid,",") For Each bid in Boardidlist If Bid<> 0 and Bid<>"" Then LoadBoardData CLng(bid) End If Next End Sub Public Sub ReloadBoardInfo(lboardid) Dim Boardidlist,bid Boardidlist=Split(lboardid,",") For Each bid in Boardidlist If Bid<> 0 and Bid<>"" Then bid=CLng(Trim(bid)) '是否更新缓存的判断,定义为30秒内不重复更新。 If Not IsObject(Application(CacheName &"_information_" & bid)) Then LoadBoardinformation bid Application.Lock Application(CacheName &"_information_" & bid).documentElement.attributes.setNamedItem(Application(CacheName &"_information_" & bid).createNode(2,"lastupdate","")).text=Now() Application.unLock Else If Application(CacheName &"_information_" & bid).documentElement.selectSingleNode("@lastupdate") is Nothing Then Application.Lock Application(CacheName &"_information_" & bid).documentElement.attributes.setNamedItem(Application(CacheName &"_information_" & bid).createNode(2,"lastupdate","")).text=Now() Application.unLock LoadBoardinformation bid Application.Lock Application(CacheName &"_information_" & bid).documentElement.attributes.setNamedItem(Application(CacheName &"_information_" & bid).createNode(2,"lastupdate","")).text=Now() Application.unLock Else If DateDiff("s",Application(CacheName &"_information_" & bid).documentElement.selectSingleNode("@lastupdate").text,Now()) > 30 Then Application.Lock Application(CacheName &"_information_" & bid).documentElement.attributes.setNamedItem(Application(CacheName &"_information_" & bid).createNode(2,"lastupdate","")).text=Now() Application.unLock LoadBoardinformation bid Application.Lock Application(CacheName &"_information_" & bid).documentElement.attributes.setNamedItem(Application(CacheName &"_information_" & bid).createNode(2,"lastupdate","")).text=Now() Application.unLock End If End If End If 'Application.Lock 'Application.Contents.Remove(CacheName &"_information_" & bid) 'Application.unLock End If Next End Sub '取得带端口的URL Property Get Get_ScriptNameUrl() If request.servervariables("SERVER_PORT")="80" Then Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"") Else Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"") End If End Property Public Function GetBrowser() Dim Agent,XSLTemplate,proc Set Agent=Application(CacheName&"_forum_lockip").cloneNode(True) Agent.documentElement.attributes.setNamedItem(Agent.createNode(2,"ip","")).text=UserTrueIP Agent.documentElement.attributes.setNamedItem(Agent.createNode(2,"actforip","")).text=actforip Agent.documentElement.appendChild(Agent.createTextNode(Request.ServerVariables("HTTP_USER_AGENT"))) Set XSLTemplate=Application(CacheName & "_getbrowser") Set proc = XSLTemplate.createProcessor() proc.input = Agent proc.transform() Set Agent=Nothing Set GetBrowser=Dvbbs.CreateXmlDoc("msxml2.FreeThreadedDOMDocument"& MsxmlVersion) GetBrowser.loadxml proc.output End Function '--------------------------------------------------- '记录道具操作日志信息(发生数量,记录事件类型,备注内容,用户最后剩余金币和点券(金币|点券)) 'Log_ID,ToolsID,CountNum,Log_Money,Log_Ticket,AddUserName,AddUserID,Log_IP,Log_Time,Log_Type,BoardID,Conect,HMoney 'Log_Type类型(0=其它,1=使用,2=转让,3=充值,4=购买,5=奖励,6=vip交易) 'HMoney最后剩余金币和点券(金币|点券) 'boardid 记录版面参数,后台为-1 '--------------------------------------------------- Public Sub ToolsLog(Log_ToolsID,CountNum,Log_Money,Log_Ticket,Log_Type,Conect,HMoney) Dim Sql Conect = CheckStr(Conect) HMoney = CheckStr(HMoney) Sql = "Insert into [Dv_MoneyLog] (ToolsID,CountNum,Log_Money,Log_Ticket,AddUserName,AddUserID,Log_IP,Log_Type,BoardID,Conect,HMoney) values (" &_ CheckNumeric(Log_ToolsID) &","&_ CheckNumeric(CountNum) &","&_ CheckNumeric(Log_Money) &","&_ CheckNumeric(Log_Ticket) &",'"&_ MemberName &"',"&_ UserID &",'"&_ UserTrueIP &"',"&_ Log_Type &","&_ BoardID &",'"&_ Conect &"','"&_ HMoney &"'"&_ ")" 'Response.Write Sql Dvbbs.Plus_Execute(Sql) End Sub '是否真正的搜索引擎 Public Function IsWebSearch() IsWebSearch = False Dim Botlist,i BotList = "Google,Isaac,SurveyBot,Baiduspider,yahoo,yisou,3721,ia_archiver,P.Arthur,FAST-WebCrawler,Java,Microsoft-ATL-Native,TurnitinBot,WebGather,Sleipnir" Botlist = Split(Botlist,",") For i = 0 To Ubound(Botlist) If InStr(Lcase(Request.ServerVariables("HTTP_USER_AGENT")),Lcase(Botlist(i))) > 0 Then IsWebSearch = True Exit For End If Next End Function Public Sub Cache_GroupName() Dim Rs,Sql Set Rs = Dvbbs.Execute("Select ID,GroupName,UserNum,Stats From Dv_GroupName order by id") If Not Rs.Eof Then Sql = Rs.GetRows(-1) End If Rs.Close Set Rs = Nothing Application(CacheName & "_GroupName") = Sql 'Response.Write "更新" End Sub Rem Flash 组图插件开始 Public Sub Load_qcomic_plus() If Not IsObject( Application(Dvbbs.CacheName&"_qcomic_plus")) Then Dim XMLDom_,rs_,Node Set rs_ = Dvbbs.Execute("Select * From Dv_Qcomic") Set XMLDom_=Dvbbs.RecordsetToxml(rs_,"setting","qcomic") If Not XMLDom_.documentElement.hasChildNodes Then Set Node = XMLDom_.documentElement.appendChild(XMLDom_.createNode(1,"setting","")) Node.setAttribute "senable",0 End If Application.Lock Set Application(Dvbbs.CacheName & "_qcomic_plus") = XMLDom_'.documentElement.cloneNode(True) Application.UnLock End If End Sub Property Get qcomic_plus() Load_qcomic_plus() Dim str_senable,senable,boardlist,plus_enable str_senable = Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@senable").text senable = Split(str_senable,"|||")(0) boardlist = Split(str_senable,"|||")(1) plus_enable = false If (Instr(boardlist, ",0,")>0 And senable="1") Then plus_enable = True If (Instr(boardlist, ","&Dvbbs.Boardid&",")>0 And senable="1") Then plus_enable = True If (plus_enable=True) Then qcomic_plus = True Else qcomic_plus = False End If End Property Function qcomic_plus_setting() Load_qcomic_plus() qcomic_plus_setting = Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@semail").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@sid").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@spassword").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@skey").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@owidth").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@oheight").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@iwidth").text qcomic_plus_setting = qcomic_plus_setting & "||||" & Application(Dvbbs.CacheName & "_qcomic_plus").documentElement.selectSingleNode("setting/@iheight").text End Function Public Function ReplaceUbb(Textstr) Dim Str,re Str=Textstr Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="\[(.[^]]*)\]" Str=re.Replace(Str, "") Set Re=Nothing ReplaceUbb=Str End Function Rem Flash 组图插件结束 End Class Class cls_Templates Public Folder,ChildFolder,tplname,Cache Private Sub Class_Initialize() Folder="Resource" ChildFolder="Template_1" Cache=False End Sub Public Function Html(index) if(Not Cache ) Then Html=Dvbbs.ReadTextFile(Folder&"\"&ChildFolder&"\"&tplname&"_html"&index&".htm") Else Dvbbs.Name="tpl" & Folder&"\"&ChildFolder&"\"&tplname&"_html"&index if Dvbbs.ObjIsEmpty() Then Dvbbs.Value=Dvbbs.ReadTextFile(Folder&"\"&ChildFolder&"\"&tplname&"_html"&index&".htm") End if Html=Dvbbs.Value End If html=Replace(html,"{$PicUrl}",Dvbbs.Forum_PicUrl) End Function Public Function Pic(index) if(Not Cache ) Then Pic=Dvbbs.Forum_PicUrl&Dvbbs.ReadTextFile((Folder&"\"&ChildFolder&"\")&tplname&"_Pic"&index&".htm") Else Dvbbs.Name="tpl" & Folder&"\"&ChildFolder&"\"&tplname&"_Pic"&index if Dvbbs.ObjIsEmpty() Then Dvbbs.Value=Dvbbs.ReadTextFile(Folder&"\"&ChildFolder&"\"&tplname&"_Pic"&index&".htm") End If If InStr(Dvbbs.Value,"{$PicUrl}")>0 Then Pic=Dvbbs.Forum_PicUrl&Dvbbs.Value Else Pic=Dvbbs.Value End if End If Pic=Replace(Pic,"{$PicUrl}","") End Function Public Function Strings(index) if(Not Cache ) Then Strings=Dvbbs.ReadTextFile((Folder&"\"&ChildFolder&"\")&tplname&"_Strings"&index&".htm") Else Dvbbs.Name="tpl" & Folder&"\"&ChildFolder&"\"&tplname&"_Strings"&index if Dvbbs.ObjIsEmpty() Then Dvbbs.Value=Dvbbs.ReadTextFile(Folder&"\"&ChildFolder&"\"&tplname&"_Strings"&index&".htm") End if Strings=Dvbbs.Value End If End Function Private Sub class_terminate() End Sub End Class Class cls_UserOnlne Public Forum_Online,Forum_UserOnline,Forum_GuestOnline Private l_Online,l_GuestOnline Private Sub Class_Initialize() Dim Reloadtime Reloadtime=Dvbbs.Reloadtime Dvbbs.Name="Forum_Online" Dvbbs.Reloadtime=60 If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum Dvbbs.Name="Forum_Online" Forum_Online = Dvbbs.Value Dvbbs.Name="Forum_UserOnline" If Dvbbs.ObjIsEmpty() Then ReflashOnlineNum Forum_UserOnline=Dvbbs.Value If Forum_Online < 0 Or Forum_UserOnline < 0 Or Forum_UserOnline > Forum_Online Then ReflashOnlineNum Forum_GuestOnline = Forum_Online - Forum_UserOnline l_Online=-1:l_GuestOnline=-1 Dvbbs.Reloadtime=Reloadtime End Sub Public Sub OnlineQuery() Dim SQL,SQL1,Delflag Dim TempNum,TempNum1 Delflag=False Dvbbs.Name="delOnline_time" If Dvbbs.ObjIsEmpty() Then Delflag=True:Dvbbs.Value=Now() Else If DateDiff("s",Dvbbs.Value,Now()) > Clng(Dvbbs.Forum_Setting(8))*10 Then Delflag=True End If If Delflag Then Dvbbs.Value=Now() If Not IsObject(Conn) Then ConnectionDatabase If IsSqlDataBase = 1 Then SQL = "Delete From [DV_Online] Where UserID=0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & Clng(Dvbbs.Forum_Setting(8)) SQL1 = "Delete From [DV_Online] Where UserID>0 And Datediff(Mi, Lastimebk, " & SqlNowString & ") > " & Clng(Dvbbs.Forum_Setting(8)) Else SQL = "Delete From [Dv_Online] Where UserID=0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60" SQL1 = "Delete From [Dv_Online] Where UserID>0 And Datediff('s', Lastimebk, " & SqlNowString & ") > " & Dvbbs.Forum_Setting(8) & "*60" End If Conn.Execute SQL,TempNum Conn.Execute SQL1,TempNum1 Dvbbs.SqlQueryNum = Dvbbs.SqlQueryNum + 2 '如果删除客人数大于0,则应该更新总数 If TempNum>0 Then '更新缓存总在线数据 Forum_Online = Forum_Online - TempNum Forum_GuestOnline = Forum_GuestOnline - TempNum End If '如果删除用户数大于0,则应该更新总数和用户数 If TempNum1>0 Or TempNum>0 Then '更新缓存总在线数据 Forum_Online = Forum_Online - TempNum1 Forum_UserOnline = Forum_UserOnline - TempNum1 End If Dvbbs.Name="Forum_Online" Dvbbs.Value=Forum_Online '更新缓存总用户在线数据 Dvbbs.Name="Forum_UserOnline" Dvbbs.Value=Forum_UserOnline Forum_Online = Forum_Online - TempNum1 End If End Sub '刷新在线数据缓存 Public Sub ReflashOnlineNum Dim Rs Dvbbs.Name="Forum_Online" Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online") Dvbbs.Value=Rs(0) Forum_Online = Dvbbs.Value Dvbbs.Name="Forum_UserOnline" Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online Where UserID>0") If Not IsNull(Rs(0)) Then Dvbbs.Value=Rs(0) Else Dvbbs.Value=0 End If Forum_UserOnline = Dvbbs.Value Rs.close() Set Rs=Nothing End Sub '查询在某版面的在线总数 Public Property Get Board_Online Board_Online=Board_UserOnline+Board_GuestOnline End Property Public Property Get Board_GuestOnline If l_GuestOnline=-1 Then Dim Rs Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online where BoardID="&Dvbbs.BoardID&" and UserID=0") l_GuestOnline=Rs(0):Rs.Close:Set Rs= Nothing End If If IsNull(l_GuestOnline) Then l_GuestOnline=0 Board_GuestOnline=l_GuestOnline End Property Public Property Get Board_UserOnline If l_Online=-1 Then Dim Rs Set Rs=Dvbbs.Execute("Select Count(*) From Dv_Online where BoardID="&Dvbbs.BoardID&" and UserID>0") l_Online=Rs(0):Rs.Close:Set Rs= Nothing End If Board_UserOnline=l_Online End Property End Class Dvbbs.PageInit() %>